diff --git a/gnucash/report/report-system/report-system.scm b/gnucash/report/report-system/report-system.scm index f600835cf1..ab45ea26c0 100644 --- a/gnucash/report/report-system/report-system.scm +++ b/gnucash/report/report-system/report-system.scm @@ -695,6 +695,7 @@ (export gnc:commodity-collectorlist-get-merged) (export gnc-commodity-collector-commodity-count) (export gnc:account-get-balance-at-date) +(export gnc:account-get-balances-at-dates) (export gnc:account-get-comm-balance-at-date) (export gnc:account-get-comm-value-interval) (export gnc:account-get-comm-value-at-date) diff --git a/gnucash/report/report-system/report-utilities.scm b/gnucash/report/report-system/report-utilities.scm index f01a97a4d5..e2fa050e93 100644 --- a/gnucash/report/report-system/report-utilities.scm +++ b/gnucash/report/report-system/report-utilities.scm @@ -386,11 +386,85 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.") ;; 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. +;; I think this (gnc:account-get-balance-at-date) is flawed in sub-acct handling. +;; Consider account structure: +;; Assets [USD] - bal=$0 +;; Bank [USD] - bal=$100 +;; Broker [USD] - bal=$200 +;; Cash [USD] - bal=$800 +;; Funds [FUND] - bal=3 FUND @ $1000 each = $3000 +;; - Calling (gnc:account-get-balance-at-date BANK TODAY #f) returns 100 +;; - Calling (gnc:account-get-balance-at-date BROKER TODAY #f) returns 200 +;; - Calling (gnc:account-get-balance-at-date BROKER TODAY #t) returns 1000 +;; this is because although it counts all subaccounts bal $200 + $800 + 3FUND, +;; it retrieves the parent account commodity USD $1000 only. +;; It needs to be deprecated. (define (gnc:account-get-balance-at-date account date include-children?) + (issue-deprecation-warning "this gnc:account-get-balance-at-date function is \ +flawed. see report-utilities.scm. please update reports.") (let ((collector (gnc:account-get-comm-balance-at-date account date include-children?))) (cadr (collector 'getpair (xaccAccountGetCommodity account) #f)))) +;; this function will scan through the account splitlist, building +;; a list of balances along the way at dates specified in dates-list. +;; in: account +;; dates-list (list of time64) +;; ignore-closing? - if #true, will skip closing entries +;; out: (list bal0 bal1 ...), each entry is a gnc-monetary object +(define* (gnc:account-get-balances-at-dates account dates-list #:key ignore-closing?) + (define (amount->monetary bal) + (gnc:make-gnc-monetary (xaccAccountGetCommodity account) bal)) + (let loop ((splits (xaccAccountGetSplitList account)) + (dates-list dates-list) + (currentbal 0) + (lastbal 0) + (balancelist '())) + (cond + + ;; end of dates. job done! + ((null? dates-list) + (map amount->monetary (reverse balancelist))) + + ;; end of splits, but still has dates. pad with last-bal + ;; until end of dates. + ((null? splits) + (loop '() + (cdr dates-list) + currentbal + lastbal + (cons lastbal balancelist))) + + (else + (let* ((this (car splits)) + (rest (cdr splits)) + (currentbal (if (and ignore-closing? + (xaccTransGetIsClosingTxn (xaccSplitGetParent this))) + currentbal + (+ (xaccSplitGetAmount this) currentbal))) + (next (and (pair? rest) (car rest)))) + + (cond + ;; the next split is still before date + ((and next (< (xaccTransGetDate (xaccSplitGetParent next)) (car dates-list))) + (loop rest dates-list currentbal lastbal balancelist)) + + ;; this split after date, add previous bal to balancelist + ((< (car dates-list) (xaccTransGetDate (xaccSplitGetParent this))) + (loop splits + (cdr dates-list) + lastbal + lastbal + (cons lastbal balancelist))) + + ;; this split before date, next split after date, or end. + (else + (loop rest + (cdr dates-list) + currentbal + currentbal + (cons currentbal balancelist))))))))) + ;; This works similar as above but returns a commodity-collector, ;; thus takes care of children accounts with different currencies. (define (gnc:account-get-comm-balance-at-date diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index ba23a977b8..10181aec96 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -24,10 +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 utilities)) +(use-modules (gnucash utilities)) (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) @@ -44,15 +42,15 @@ ;; The names are used in the menu ;; The menu statusbar tips. -(define menutip-income +(define menutip-income (N_ "Shows a chart with the Income per interval \ developing over time")) -(define menutip-expense +(define menutip-expense (N_ "Shows a chart with the Expenses per interval \ developing over time")) -(define menutip-assets +(define menutip-assets (N_ "Shows a chart with the Assets developing over time")) -(define menutip-liabilities +(define menutip-liabilities (N_ "Shows a chart with the Liabilities \ developing over time")) @@ -89,8 +87,8 @@ developing over time")) (define opthelp-averaging (N_ "Select whether the amounts should be shown over the full time period or rather as the average e.g. per month.")) (define (options-generator account-types reverse-balance? do-intervals?) - (let* ((options (gnc:new-options)) - (add-option + (let* ((options (gnc:new-options)) + (add-option (lambda (new-option) (gnc:register-option options new-option)))) @@ -103,13 +101,13 @@ developing over time")) options gnc:pagename-general optname-from-date optname-to-date "a") - (gnc:options-add-interval-choice! + (gnc:options-add-interval-choice! options gnc:pagename-general optname-stepsize "b" 'MonthDelta) - (gnc:options-add-currency! + (gnc:options-add-currency! options gnc:pagename-general optname-report-currency "c") - (gnc:options-add-price-source! + (gnc:options-add-price-source! options gnc:pagename-general optname-price-source "d" 'weighted-average) @@ -130,10 +128,7 @@ developing over time")) (N_ "Show the average weekly amount during the reporting period.")) (vector 'DayDelta (N_ "Daily") - (N_ "Show the average daily amount during the reporting period.")) - ) - )) - ) + (N_ "Show the average daily amount during the reporting period.")))))) ;; Accounts tab @@ -143,17 +138,17 @@ developing over time")) "a" (N_ "Report on these accounts, if chosen account level allows.") (lambda () - (gnc:filter-accountlist-type + (gnc:filter-accountlist-type account-types (gnc-account-get-descendants-sorted (gnc-get-current-root-account)))) (lambda (accounts) (list #t (gnc:filter-accountlist-type account-types accounts))) #t)) - - (gnc:options-add-account-levels! - options gnc:pagename-accounts optname-levels "c" - (N_ "Show accounts to this depth and not further.") + + (gnc:options-add-account-levels! + options gnc:pagename-accounts optname-levels "c" + (N_ "Show accounts to this depth and not further.") 2) ;; Display tab @@ -163,19 +158,16 @@ developing over time")) "a" (N_ "Show the full account name in legend?") #f)) (add-option - (gnc:make-multichoice-option - gnc:pagename-display optname-chart-type - "b" "Select which chart type to use" - 'barchart - (list (vector 'barchart - (N_ "Bar Chart") - (N_ "Use bar charts.")) - (vector 'linechart - (N_ "Line Chart") - (N_ "Use line charts.")) - ) - ) - ) + (gnc:make-multichoice-option + gnc:pagename-display optname-chart-type + "b" "Select which chart type to use" + 'barchart + (list (vector 'barchart + (N_ "Bar Chart") + (N_ "Use bar charts.")) + (vector 'linechart + (N_ "Line Chart") + (N_ "Use line charts."))))) (add-option (gnc:make-simple-boolean-option @@ -197,11 +189,11 @@ developing over time")) "e" (N_ "Display a table of the selected data.") #f)) - (gnc:options-add-plot-size! - options gnc:pagename-display + (gnc:options-add-plot-size! + options gnc:pagename-display optname-plot-width optname-plot-height "f" (cons 'percent 100.0) (cons 'percent 100.0)) - (gnc:options-add-sort-method! + (gnc:options-add-sort-method! options gnc:pagename-display optname-sort-method "g" 'amount) @@ -221,80 +213,72 @@ developing over time")) ;; constant over the whole report period. Note that this might get ;; *really* complicated. -(define (category-barchart-renderer report-obj reportname reportguid +(define (category-barchart-renderer report-obj reportname reportguid account-types do-intervals?) ;; A helper functions for looking up option values. (define (get-option section name) - (gnc:option-value - (gnc:lookup-option + (gnc:option-value + (gnc:lookup-option (gnc:report-options report-obj) section name))) - + (gnc:report-starting reportname) (let* ((to-date-t64 (gnc:time64-end-day-time (gnc:date-option-absolute-time - (get-option gnc:pagename-general + (get-option gnc:pagename-general optname-to-date)))) - (from-date-t64 (gnc:time64-start-day-time - (gnc:date-option-absolute-time - (get-option gnc:pagename-general - optname-from-date)))) - (interval (get-option gnc:pagename-general optname-stepsize)) - (report-currency (get-option gnc:pagename-general - optname-report-currency)) - (price-source (get-option gnc:pagename-general - optname-price-source)) - (report-title (get-option gnc:pagename-general - gnc:optname-reportname)) - (averaging-selection (if do-intervals? - (get-option gnc:pagename-general - optname-averaging) - 'None)) - - (accounts (get-option gnc:pagename-accounts optname-accounts)) - (account-levels (get-option gnc:pagename-accounts optname-levels)) - - (chart-type (get-option gnc:pagename-display optname-chart-type)) - (stacked? (get-option gnc:pagename-display optname-stacked)) - (show-fullname? (get-option gnc:pagename-display optname-fullname)) - (max-slices (inexact->exact - (get-option gnc:pagename-display optname-slices))) - (height (get-option gnc:pagename-display optname-plot-height)) - (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?")) - - (show-table? (get-option gnc:pagename-display (N_ "Show table"))) - (document (gnc:make-html-document)) - (chart - (if (eqv? chart-type 'barchart) - (gnc:make-html-barchart) - (gnc:make-html-linechart) - )) - (table (gnc:make-html-table)) - (topl-accounts (gnc:filter-accountlist-type - account-types - (gnc-account-get-children-sorted - (gnc-get-current-root-account))))) - + (from-date-t64 (gnc:time64-start-day-time + (gnc:date-option-absolute-time + (get-option gnc:pagename-general + optname-from-date)))) + (interval (get-option gnc:pagename-general optname-stepsize)) + (report-currency (get-option gnc:pagename-general + optname-report-currency)) + (price-source (get-option gnc:pagename-general + optname-price-source)) + (report-title (get-option gnc:pagename-general + gnc:optname-reportname)) + (averaging-selection (if do-intervals? + (get-option gnc:pagename-general + optname-averaging) + 'None)) + + (accounts (get-option gnc:pagename-accounts optname-accounts)) + (account-levels (get-option gnc:pagename-accounts optname-levels)) + + (chart-type (get-option gnc:pagename-display optname-chart-type)) + (stacked? (get-option gnc:pagename-display optname-stacked)) + (show-fullname? (get-option gnc:pagename-display optname-fullname)) + (max-slices (inexact->exact + (get-option gnc:pagename-display optname-slices))) + (height (get-option gnc:pagename-display optname-plot-height)) + (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 (if (eqv? chart-type 'barchart) + (gnc:make-html-barchart) + (gnc:make-html-linechart))) + (table (gnc:make-html-table)) + (topl-accounts (gnc:filter-accountlist-type + account-types + (gnc-account-get-children-sorted + (gnc-get-current-root-account))))) + ;; Returns true if the account a was selected in the account ;; selection option. (define (show-acct? a) (member a accounts)) - (define tree-depth (if (equal? account-levels 'all) + (define tree-depth (if (eq? account-levels 'all) (gnc:get-current-account-tree-depth) account-levels)) - (define the-acount-destination-alist - (account-destination-alist accounts account-types tree-depth)) - ;;(gnc:debug accounts) (if (not (null? accounts)) - (if (null? the-acount-destination-alist) - (gnc:html-document-add-object! - document - (gnc:html-make-empty-data-warning - report-title (gnc:report-id report-obj))) ;; Define more helper variables. (let* ((commodity-list #f) @@ -302,45 +286,39 @@ developing over time")) (averaging-fraction-func (gnc:date-get-fraction-func averaging-selection)) (interval-fraction-func (gnc:date-get-fraction-func interval)) (averaging-multiplier - (if averaging-fraction-func - ;; Calculate the divisor of the amounts so that an - ;; average is shown. Multiplier factor is a gnc-numeric - (let* ((start-frac-avg (averaging-fraction-func from-date-t64)) - (end-frac-avg (averaging-fraction-func (+ 1 to-date-t64))) - (diff-avg (- end-frac-avg start-frac-avg)) - (diff-avg-numeric (/ - (inexact->exact (round (* diff-avg 1000000))) ; 6 decimals precision + (if averaging-fraction-func + ;; Calculate the divisor of the amounts so that an + ;; average is shown. Multiplier factor is a gnc-numeric + (let* ((start-frac-avg (averaging-fraction-func from-date-t64)) + (end-frac-avg (averaging-fraction-func (1+ to-date-t64))) + (diff-avg (- end-frac-avg start-frac-avg)) + (diff-avg-numeric (/ (inexact->exact (round (* diff-avg 1000000))) ; 6 decimals precision 1000000)) - (start-frac-int (interval-fraction-func from-date-t64)) - (end-frac-int (interval-fraction-func (+ 1 to-date-t64))) - (diff-int (- end-frac-int start-frac-int)) - (diff-int-numeric (/ - (inexact->exact diff-int) 1)) - ) - ;; Extra sanity check to ensure a number smaller than 1 - (if (> diff-avg diff-int) - (gnc-numeric-div diff-int-numeric diff-avg-numeric GNC-DENOM-AUTO GNC-RND-ROUND) - 1/1)) - 1/1)) + (start-frac-int (interval-fraction-func from-date-t64)) + (end-frac-int (interval-fraction-func (1+ to-date-t64))) + (diff-int (- end-frac-int start-frac-int)) + (diff-int-numeric (inexact->exact diff-int))) + ;; Extra sanity check to ensure a number smaller than 1 + (if (> diff-avg diff-int) + (/ diff-int-numeric diff-avg-numeric) + 1)) + 1)) ;; If there is averaging, the report-title is extended ;; accordingly. (report-title - (case averaging-selection - ((MonthDelta) (string-append report-title " " (_ "Monthly Average"))) - ((WeekDelta) (string-append report-title " " (_ "Weekly Average"))) - ((DayDelta) (string-append report-title " " (_ "Daily Average"))) - (else report-title))) + (case averaging-selection + ((MonthDelta) (string-append report-title " " (_ "Monthly Average"))) + ((WeekDelta) (string-append report-title " " (_ "Weekly Average"))) + ((DayDelta) (string-append report-title " " (_ "Daily Average"))) + (else report-title))) (currency-frac (gnc-commodity-get-fraction report-currency)) ;; This is the list of date intervals to calculate. - (dates-list (if do-intervals? - (gnc:make-date-interval-list - (gnc:time64-start-day-time from-date-t64) - (gnc:time64-end-day-time to-date-t64) - (gnc:deltasym-to-delta interval)) - (gnc:make-date-list - (gnc:time64-end-day-time from-date-t64) - (gnc:time64-end-day-time to-date-t64) - (gnc:deltasym-to-delta interval)))) + (dates-list (gnc:make-date-list + ((if do-intervals? + gnc:time64-start-day-time + gnc:time64-end-day-time) from-date-t64) + (gnc:time64-end-day-time to-date-t64) + (gnc:deltasym-to-delta interval))) ;; Here the date strings for the x-axis labels are ;; created. (date-string-list '()) @@ -349,71 +327,105 @@ developing over time")) (other-anchor "") (all-data '())) - (define (datelist->stringlist dates-list) - (map (lambda (date-list-item) - (qof-print-date - (if do-intervals? - (car date-list-item) - date-list-item))) - dates-list)) - ;; Converts a commodity-collector into gnc-monetary in the report's ;; currency using the exchange-fn calculated above. Returns a gnc-monetary ;; multiplied by the averaging-multiplier (smaller than one; multiplication ;; instead of division to avoid division-by-zero issues) in case ;; the user wants to see the amounts averaged over some value. (define (collector->monetary c date) - (if (not (number? date)) - (throw 'wrong)) (gnc:make-gnc-monetary report-currency - (gnc-numeric-mul - (gnc:gnc-monetary-amount - (gnc:sum-collector-commodity - c report-currency - (lambda (a b) (exchange-fn a b date)))) - averaging-multiplier currency-frac GNC-RND-ROUND) - )) - - ;; Add two or more gnc-monetary objects - (define (monetary+ a . blist) - (if (null? blist) - a - (let ((b (apply monetary+ blist))) - (if (and (gnc:gnc-monetary? a) (gnc:gnc-monetary? b)) - (let ((same-currency? (gnc-commodity-equal (gnc:gnc-monetary-commodity a) (gnc:gnc-monetary-commodity b))) - (amount (gnc-numeric-add (gnc:gnc-monetary-amount a) (gnc:gnc-monetary-amount b) GNC-DENOM-AUTO GNC-RND-ROUND))) - (if same-currency? - (gnc:make-gnc-monetary (gnc:gnc-monetary-commodity a) amount) - (warn "incompatible currencies in monetary+: " a b))) - (warn "wrong arguments for monetary+: " a b))) - ) - ) - - ;; Extract value of gnc-monetary and return it as double - (define (monetary->double monetary) - (gnc-numeric-to-double (gnc:gnc-monetary-amount monetary))) + (* averaging-multiplier + (gnc:gnc-monetary-amount + (gnc:sum-collector-commodity + c report-currency + (lambda (a b) (exchange-fn a b date))))))) + + (define (monetaries-add . monetaries) + (let ((coll (gnc:make-commodity-collector))) + (for-each + (lambda (mon) + (coll 'add (gnc:gnc-monetary-commodity mon) (gnc:gnc-monetary-amount mon))) + monetaries) + coll)) + + ;; Special case for monetaries-add whereby only 1 currency is expected + (define (monetary+ . monetaries) + (let ((coll (apply monetaries-add monetaries))) + (if (= 1 (gnc-commodity-collector-commodity-count coll)) + (car (coll 'format gnc:make-gnc-monetary #f)) + (gnc:warn "monetary+ expects 1 currency " (gnc:strify monetaries))))) + + (define (collector-minus a b) + (let ((coll (gnc:make-commodity-collector))) + (coll 'merge a #f) + (coll 'minusmerge b #f) + coll)) ;; copy of gnc:not-all-zeros using gnc-monetary (define (not-all-zeros data) - (define (myor list) - (begin - (if (null? list) #f - (or (car list) (myor (cdr list)))))) - (cond ((gnc:gnc-monetary? data) (not (gnc-numeric-zero-p (gnc:gnc-monetary-amount data)))) - ((list? data) (myor (map not-all-zeros data))) + (cond ((gnc:gnc-monetary? data) (not (zero? (gnc:gnc-monetary-amount data)))) + ((list? data) (or-map not-all-zeros data)) (else #f))) - (define (count-accounts current-depth accts) - (if (< current-depth tree-depth) - (let ((sum 0)) - (for-each - (lambda (a) - (set! sum (+ sum (+ 1 (count-accounts (+ 1 current-depth) - (gnc-account-get-children a)))))) - accts) - sum) - (length (filter show-acct? accts)))) + ;; this is an alist of account-balances + ;; (list (list acc0 bal0 bal1 bal2 ...) + ;; (list acc1 bal0 bal1 bal2 ...) + ;; ...) + ;; whereby each balance is a gnc-monetary + (define account-balances-alist + (map + (lambda (acc) + (cons acc + (map + (if (reverse-balance? acc) gnc:monetary-neg identity) + (gnc:account-get-balances-at-dates + acc dates-list + #:ignore-closing? (gnc:account-is-inc-exp? acc))))) + accounts)) + + ;; Creates the to be used in the function + ;; below. + (define (account->balance-list account subacct?) + (let* ((accountslist (cons account + (if subacct? + (gnc-account-get-descendants account) + '()))) + (selected-balances (filter + (lambda (entry) + (member (car entry) accountslist)) + account-balances-alist)) + (selected-monetaries (map cdr selected-balances)) + (list-of-mon-collectors (apply map monetaries-add selected-monetaries))) + (let loop ((list-of-mon-collectors list-of-mon-collectors) + (dates-list dates-list) + (result '())) + (if (null? (if do-intervals? + (cdr list-of-mon-collectors) + list-of-mon-collectors)) + (reverse result) + (loop (cdr list-of-mon-collectors) + (cdr dates-list) + (cons (if do-intervals? + (collector->monetary + (collector-minus (cadr list-of-mon-collectors) + (car list-of-mon-collectors)) + (cadr dates-list)) + (collector->monetary + (car list-of-mon-collectors) + (car dates-list))) + result)))))) + + (define (count-accounts current-depth accts) + (if (< current-depth tree-depth) + (let ((sum 0)) + (for-each + (lambda (a) + (set! sum (+ sum (1+ (count-accounts (1+ current-depth) + (gnc-account-get-children a)))))) + accts) + sum) + (length (filter show-acct? accts)))) ;; Calculates all account's balances. Returns a list of pairs: ;; ( ), like '((Earnings (10.0 11.2)) @@ -429,34 +441,33 @@ 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 (apply-sign account x) - (if (reverse-balance? account) (gnc:monetary-neg x) x)) - (define (calculate-report accounts progress-range) - (let* ((account-reformat - (if do-intervals? - (lambda (account result) - (map (lambda (collector datepair) - (let ((date (second datepair))) - (apply-sign account (collector->monetary 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->monetary commodity-collector - date)))) - (collector-into-list) - result dates-list)))))) - - (the-work (category-by-account-report-work do-intervals? - dates-list the-acount-destination-alist - (lambda (account date) - (make-gnc-collector-collector)) - account-reformat)) - (the-report (category-by-account-report-do-work the-work progress-range))) - the-report)) + (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)))) + ;; The percentage done numbers here are a hack so that ;; something gets displayed. On my system the @@ -465,248 +476,248 @@ developing over time")) ;; routine needs to send progress reports, or the price ;; lookup should be distributed and done when actually ;; needed so as to amortize the cpu time properly. - (gnc:report-percent-done 1) - (set! commodity-list (gnc:accounts-get-commodities - (append + (gnc:report-percent-done 1) + (set! commodity-list (gnc:accounts-get-commodities + (append (gnc:acccounts-get-all-subaccounts accounts) accounts) report-currency)) - (set! exchange-fn (gnc:case-exchange-time-fn - price-source report-currency + (set! exchange-fn (gnc:case-exchange-time-fn + price-source report-currency commodity-list to-date-t64 - 5 15)) + 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 (gnc-numeric-equal (gnc-numeric-zero) - (gnc:gnc-monetary-amount (apply monetary+ (cadr l)))))) - (calculate-report accounts (cons 0 90))) - (cond - ((eq? sort-method 'acct-code) - (lambda (a b) - (string (gnc-numeric-compare (gnc:gnc-monetary-amount (apply monetary+ (cadr a))) - (gnc:gnc-monetary-amount (apply monetary+ (cadr b)))) - 0))) - ))) + (not (zero? + (gnc:gnc-monetary-amount + (apply monetary+ (cadr l)))))) + (traverse-accounts 1 topl-accounts)) + (cond + ((eq? sort-method 'acct-code) + (lambda (a b) + (string (gnc:gnc-monetary-amount (apply monetary+ (cadr a))) + (gnc:gnc-monetary-amount (apply monetary+ (cadr b))))))))) ;; Or rather sort by total amount? - ;;(< (apply + (cadr a)) + ;;(< (apply + (cadr a)) ;; (apply + (cadr b)))))) ;; Other sort criteria: max. amount, standard deviation of amount, ;; min. amount; ascending, descending. FIXME: Add user options to ;; choose sorting. - - + + ;;(gnc:warn "all-data" all-data) ;; Proceed if the data is non-zeros - (if + (if (and (not (null? all-data)) (not-all-zeros (map cadr all-data))) - (begin - (set! date-string-list (datelist->stringlist dates-list)) + (let ((dates-list (if do-intervals? + (list-head dates-list (1- (length dates-list))) + dates-list))) + (set! date-string-list (map qof-print-date dates-list)) (qof-date-format-set QOF-DATE-FORMAT-ISO) - (set! date-iso-string-list (datelist->stringlist dates-list)) + (set! date-iso-string-list (map qof-print-date dates-list)) (qof-date-format-set save-fmt) ;; Set chart title, subtitle etc. - (if (eqv? chart-type 'barchart) - (begin - (gnc:html-barchart-set-title! chart report-title) - (gnc:html-barchart-set-subtitle! - chart (format #f - (if do-intervals? - (_ "~a to ~a") - (_ "Balances ~a to ~a")) - (gnc:html-string-sanitize (qof-print-date from-date-t64)) - (gnc:html-string-sanitize (qof-print-date to-date-t64)))) - - (gnc:html-barchart-set-width! chart width) - (gnc:html-barchart-set-height! chart height) - - ;; row labels etc. - (gnc:html-barchart-set-row-labels! chart date-string-list) - ;; FIXME: axis labels are not yet supported by - ;; libguppitank. - (gnc:html-barchart-set-y-axis-label! - chart (gnc-commodity-get-mnemonic report-currency)) - (gnc:html-barchart-set-row-labels-rotated?! chart #t) - (gnc:html-barchart-set-stacked?! chart stacked?) - ;; If this is a stacked barchart, then reverse the legend. - ;; Doesn't do what you'd expect. - DRH - ;; It does work, but needs Guppi 0.40.4. - cstim - (gnc:html-barchart-set-legend-reversed?! chart stacked?) - ) - (begin - (gnc:html-linechart-set-title! chart report-title) - (gnc:html-linechart-set-subtitle! - chart (format #f - (if do-intervals? - (_ "~a to ~a") - (_ "Balances ~a to ~a")) - (gnc:html-string-sanitize (qof-print-date from-date-t64)) - (gnc:html-string-sanitize (qof-print-date to-date-t64)))) - - (gnc:html-linechart-set-width! chart width) - (gnc:html-linechart-set-height! chart height) - - ;; row labels etc. - (gnc:html-linechart-set-row-labels! chart date-iso-string-list) - ;; FIXME: axis labels are not yet supported by - ;; libguppitank. - (gnc:html-linechart-set-y-axis-label! - chart (gnc-commodity-get-mnemonic report-currency)) - (gnc:html-linechart-set-row-labels-rotated?! chart #t) - (gnc:html-linechart-set-stacked?! chart stacked?) - ;; If this is a stacked linechart, then reverse the legend. - ;; Doesn't do what you'd expect. - DRH - ;; It does work, but needs Guppi 0.40.4. - cstim - (gnc:html-linechart-set-legend-reversed?! chart stacked?) - ) - ) - + (if (eq? chart-type 'barchart) + (begin + (gnc:html-barchart-set-title! chart report-title) + (gnc:html-barchart-set-subtitle! + chart (format #f + (if do-intervals? + (_ "~a to ~a") + (_ "Balances ~a to ~a")) + (qof-print-date from-date-t64) + (qof-print-date to-date-t64))) + + (gnc:html-barchart-set-width! chart width) + (gnc:html-barchart-set-height! chart height) + + ;; row labels etc. + (gnc:html-barchart-set-row-labels! chart date-string-list) + ;; FIXME: axis labels are not yet supported by + ;; libguppitank. + (gnc:html-barchart-set-y-axis-label! + chart (gnc-commodity-get-mnemonic report-currency)) + (gnc:html-barchart-set-row-labels-rotated?! chart #t) + (gnc:html-barchart-set-stacked?! chart stacked?) + ;; If this is a stacked barchart, then reverse the legend. + ;; Doesn't do what you'd expect. - DRH + ;; It does work, but needs Guppi 0.40.4. - cstim + (gnc:html-barchart-set-legend-reversed?! chart stacked?) + ) + (begin + (gnc:html-linechart-set-title! chart report-title) + (gnc:html-linechart-set-subtitle! + chart (format #f + (if do-intervals? + (_ "~a to ~a") + (_ "Balances ~a to ~a")) + (qof-print-date from-date-t64) + (qof-print-date to-date-t64))) + + (gnc:html-linechart-set-width! chart width) + (gnc:html-linechart-set-height! chart height) + + ;; row labels etc. + (gnc:html-linechart-set-row-labels! chart date-iso-string-list) + ;; FIXME: axis labels are not yet supported by + ;; libguppitank. + (gnc:html-linechart-set-y-axis-label! + chart (gnc-commodity-get-mnemonic report-currency)) + (gnc:html-linechart-set-row-labels-rotated?! chart #t) + (gnc:html-linechart-set-stacked?! chart stacked?) + ;; If this is a stacked linechart, then reverse the legend. + ;; Doesn't do what you'd expect. - DRH + ;; It does work, but needs Guppi 0.40.4. - cstim + (gnc:html-linechart-set-legend-reversed?! chart stacked?) + ) + ) + ;; If we have too many categories, we sum them into a new ;; 'other' category and add a link to a new report with just ;; those accounts. (if (> (length all-data) max-slices) - (let* ((start (take all-data (- max-slices 1))) - (finish (drop all-data (- max-slices 1))) - (other-sum (map + (let* ((start (take all-data (1- max-slices))) + (finish (drop all-data (1- max-slices))) + (other-sum (map (lambda (l) (apply monetary+ l)) (apply zip (map cadr finish))))) (set! all-data - (append start - (list (list (_ "Other") other-sum)))) + (append start + (list (list (_ "Other") other-sum)))) (let* ((options (gnc:make-report-options reportguid)) (id #f)) ;; now copy all the options - (gnc:options-copy-values + (gnc:options-copy-values (gnc:report-options report-obj) options) ;; and set the destination accounts (gnc:option-set-value - (gnc:lookup-option options gnc:pagename-accounts + (gnc:lookup-option options gnc:pagename-accounts optname-accounts) (map car finish)) ;; Set the URL to point to this report. (set! id (gnc:make-report reportguid options)) (set! other-anchor (gnc:report-anchor-text id))))) - - + + ;; This adds the data. Note the apply-zip stuff: This ;; transposes the data, i.e. swaps rows and columns. Pretty ;; cool, eh? Courtesy of dave_p. - (gnc:report-percent-done 92) - (if (eqv? chart-type 'barchart) - (begin ;; bar chart - (if (not (null? all-data)) - (gnc:html-barchart-set-data! - chart - (apply zip (map (lambda (mlist) - (map monetary->double mlist)) - (map cadr all-data))))) - - ;; Labels and colors - (gnc:report-percent-done 94) - (gnc:html-barchart-set-col-labels! - chart (map (lambda (pair) - (if (string? (car pair)) - (car pair) - ((if show-fullname? - gnc-account-get-full-name - xaccAccountGetName) (car pair)))) - all-data)) - (gnc:html-barchart-set-col-colors! - chart - (gnc:assign-colors (length all-data))) - ) - (begin ;; line chart - (if (not (null? all-data)) - (gnc:html-linechart-set-data! - chart - (apply zip (map (lambda (mlist) - (map monetary->double mlist)) - (map cadr all-data))))) - - ;; Labels and colors - (gnc:report-percent-done 94) - (gnc:html-linechart-set-col-labels! - chart (map (lambda (pair) - (if (string? (car pair)) - (car pair) - ((if show-fullname? - gnc-account-get-full-name - xaccAccountGetName) (car pair)))) - all-data)) - (gnc:html-linechart-set-col-colors! - chart - (gnc:assign-colors (length all-data))) - ) - ) - + (gnc:report-percent-done 92) + (if (eq? chart-type 'barchart) + (begin ;; bar chart + (if (not (null? all-data)) + (gnc:html-barchart-set-data! + chart + (apply zip (map (lambda (mlist) + (map gnc:gnc-monetary-amount mlist)) + (map cadr all-data))))) + + ;; Labels and colors + (gnc:report-percent-done 94) + (gnc:html-barchart-set-col-labels! + chart (map (lambda (pair) + (if (string? (car pair)) + (car pair) + ((if show-fullname? + gnc-account-get-full-name + xaccAccountGetName) (car pair)))) + all-data)) + (gnc:html-barchart-set-col-colors! + chart + (gnc:assign-colors (length all-data)))) + (begin ;; line chart + (if (not (null? all-data)) + (gnc:html-linechart-set-data! + chart + (apply zip (map (lambda (mlist) + (map gnc:gnc-monetary-amount mlist)) + (map cadr all-data))))) + + ;; Labels and colors + (gnc:report-percent-done 94) + (gnc:html-linechart-set-col-labels! + chart (map (lambda (pair) + (if (string? (car pair)) + (car pair) + ((if show-fullname? + gnc-account-get-full-name + xaccAccountGetName) (car pair)))) + all-data)) + (gnc:html-linechart-set-col-colors! + chart + (gnc:assign-colors (length all-data))))) + ;; set the URLs; the slices are links to other reports -;; (gnc:report-percent-done 96) -;; (let -;; ((urls -;; (map -;; (lambda (pair) -;; (if -;; (string? (car pair)) -;; other-anchor -;; (let* ((acct (car pair)) -;; (subaccts -;; (gnc-account-get-children acct))) -;; (if (null? subaccts) -;; ;; if leaf-account, make this an anchor -;; ;; to the register. -;; (gnc:account-anchor-text acct) -;; ;; if non-leaf account, make this a link -;; ;; to another report which is run on the -;; ;; immediate subaccounts of this account -;; ;; (and including this account). -;; (gnc:make-report-anchor -;; reportguid -;; report-obj -;; (list -;; (list gnc:pagename-accounts optname-accounts -;; (cons acct subaccts)) -;; (list gnc:pagename-accounts optname-levels -;; (+ 1 tree-depth)) -;; (list gnc:pagename-general -;; gnc:optname-reportname -;; ((if show-fullname? -;; gnc-account-get-full-name -;; xaccAccountGetName) acct)))))))) -;; all-data))) -;; (if (eqv? chart-type 'barchart) -;; (begin ;; bar chart -;; (gnc:html-barchart-set-button-1-bar-urls! -;; chart (append urls urls)) -;; ;; The legend urls do the same thing. -;; (gnc:html-barchart-set-button-1-legend-urls! -;; chart (append urls urls)) -;; ) -;; (begin ;; line chart -;; (gnc:html-linechart-set-button-1-line-urls! -;; chart (append urls urls)) -;; ;; The legend urls do the same thing. -;; (gnc:html-linechart-set-button-1-legend-urls! -;; chart (append urls urls)) -;; ) -;; ) -;; ) - - (gnc:report-percent-done 98) + ;; (gnc:report-percent-done 96) + ;; (let + ;; ((urls + ;; (map + ;; (lambda (pair) + ;; (if + ;; (string? (car pair)) + ;; other-anchor + ;; (let* ((acct (car pair)) + ;; (subaccts + ;; (gnc-account-get-children acct))) + ;; (if (null? subaccts) + ;; ;; if leaf-account, make this an anchor + ;; ;; to the register. + ;; (gnc:account-anchor-text acct) + ;; ;; if non-leaf account, make this a link + ;; ;; to another report which is run on the + ;; ;; immediate subaccounts of this account + ;; ;; (and including this account). + ;; (gnc:make-report-anchor + ;; reportguid + ;; report-obj + ;; (list + ;; (list gnc:pagename-accounts optname-accounts + ;; (cons acct subaccts)) + ;; (list gnc:pagename-accounts optname-levels + ;; (1+ tree-depth)) + ;; (list gnc:pagename-general + ;; gnc:optname-reportname + ;; ((if show-fullname? + ;; gnc-account-get-full-name + ;; xaccAccountGetName) acct)))))))) + ;; all-data))) + ;; (if (eq? chart-type 'barchart) + ;; (begin ;; bar chart + ;; (gnc:html-barchart-set-button-1-bar-urls! + ;; chart (append urls urls)) + ;; ;; The legend urls do the same thing. + ;; (gnc:html-barchart-set-button-1-legend-urls! + ;; chart (append urls urls)) + ;; ) + ;; (begin ;; line chart + ;; (gnc:html-linechart-set-button-1-line-urls! + ;; chart (append urls urls)) + ;; ;; The legend urls do the same thing. + ;; (gnc:html-linechart-set-button-1-legend-urls! + ;; chart (append urls urls)) + ;; ) + ;; ) + ;; ) + + (gnc:report-percent-done 98) (gnc:html-document-add-object! document chart) (if show-table? (begin @@ -719,29 +730,23 @@ developing over time")) (begin (gnc:html-table-append-column! table (car col)) - (addcol (cdr col)) - ) - )) - )) - (addcol (map cadr all-data)) - ) + (addcol (cdr col))))))) + (addcol (map cadr all-data))) (gnc:html-table-set-col-headers! table (append (list (_ "Date")) (map (lambda (pair) - (if (string? (car pair)) - (car pair) - ((if show-fullname? - gnc-account-get-full-name - xaccAccountGetName) (car pair)))) + (if (string? (car pair)) + (car pair) + ((if show-fullname? + gnc-account-get-full-name + xaccAccountGetName) (car pair)))) all-data) (if (> (gnc:html-table-num-columns table) 2) (list (_ "Grand Total")) - '() - ) - )) + '()))) (if (> (gnc:html-table-num-columns table) 2) (letrec @@ -749,62 +754,50 @@ developing over time")) (lambda (row) (if (null? row) '() - (cons (sumrow (car row)) (sumtot (cdr row))) - ) - ) - ) + (cons (sumrow (car row)) (sumtot (cdr row)))))) (sumrow (lambda (row) (if (not (null? row)) (monetary+ (car row) (sumrow (cdr row))) - (gnc:make-gnc-monetary report-currency (gnc-numeric-zero)) - ) - ) - )) + (gnc:make-gnc-monetary report-currency 0))))) (gnc:html-table-append-column! table - (sumtot (apply zip (map cadr all-data))) - ) - ) - ) - ;; set numeric columns to align right + (sumtot (apply zip (map cadr all-data)))))) + ;; set numeric columns to align right (for-each (lambda (col) (gnc:html-table-set-col-style! table col "td" 'attribute (list "class" "number-cell"))) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14)) - (gnc:html-document-add-object! document table) - ) ;; begin if - ) - ) + (gnc:html-document-add-object! document table)))) ;; else if empty data (gnc:html-document-add-object! document (gnc:html-make-empty-data-warning - report-title (gnc:report-id report-obj)))))) - - ;; else if no accounts selected - (gnc:html-document-add-object! - document - (gnc:html-make-no-account-warning - report-title (gnc:report-id report-obj)))) - + report-title (gnc:report-id report-obj))))) + + ;; else if no accounts selected + (gnc:html-document-add-object! + document + (gnc:html-make-no-account-warning + report-title (gnc:report-id report-obj)))) + (gnc:report-finished) document)) ;; Export reports (export category-barchart-income-uuid category-barchart-expense-uuid - category-barchart-asset-uuid category-barchart-liability-uuid) + category-barchart-asset-uuid category-barchart-liability-uuid) (define category-barchart-income-uuid "44f81bee049b4b3ea908f8dac9a9474e") (define category-barchart-expense-uuid "b1f15b2052c149df93e698fe85a81ea6") (define category-barchart-asset-uuid "e9cf815f79db44bcb637d0295093ae3d") (define category-barchart-liability-uuid "faf410e8f8da481fbc09e4763da40bcc") -(for-each +(for-each (lambda (l) (let ((tip-and-rev (cddddr l))) (gnc:define-report @@ -812,31 +805,31 @@ developing over time")) 'name (car l) 'report-guid (car (reverse l)) 'menu-path (if (caddr l) - (list gnc:menuname-income-expense) - (list gnc:menuname-asset-liability)) + (list gnc:menuname-income-expense) + (list gnc:menuname-asset-liability)) 'menu-name (cadddr l) 'menu-tip (car tip-and-rev) - 'options-generator (lambda () (options-generator (cadr l) + 'options-generator (lambda () (options-generator (cadr l) (cadr tip-and-rev) (caddr l))) 'renderer (lambda (report-obj) - (category-barchart-renderer report-obj - (car l) - (car (reverse l)) - (cadr l) - (caddr l)))))) - (list - ;; reportname, account-types, do-intervals?, + (category-barchart-renderer report-obj + (car l) + (car (reverse l)) + (cadr l) + (caddr l)))))) + (list + ;; reportname, account-types, do-intervals?, ;; menu-reportname, menu-tip (list reportname-income (list ACCT-TYPE-INCOME) #t menuname-income menutip-income (lambda (x) #t) category-barchart-income-uuid) (list reportname-expense (list ACCT-TYPE-EXPENSE) #t menuname-expense menutip-expense (lambda (x) #f) category-barchart-expense-uuid) - (list reportname-assets + (list reportname-assets (list ACCT-TYPE-ASSET ACCT-TYPE-BANK ACCT-TYPE-CASH ACCT-TYPE-CHECKING ACCT-TYPE-SAVINGS ACCT-TYPE-MONEYMRKT ACCT-TYPE-RECEIVABLE ACCT-TYPE-STOCK ACCT-TYPE-MUTUAL ACCT-TYPE-CURRENCY) #f menuname-assets menutip-assets (lambda (x) #f) category-barchart-asset-uuid) - (list reportname-liabilities + (list reportname-liabilities (list ACCT-TYPE-LIABILITY ACCT-TYPE-PAYABLE ACCT-TYPE-CREDIT ACCT-TYPE-CREDITLINE) #f menuname-liabilities menutip-liabilities (lambda (x) #t) category-barchart-liability-uuid))) diff --git a/gnucash/report/standard-reports/net-charts.scm b/gnucash/report/standard-reports/net-charts.scm index 317a2200ba..ca8ecb379b 100644 --- a/gnucash/report/standard-reports/net-charts.scm +++ b/gnucash/report/standard-reports/net-charts.scm @@ -258,71 +258,13 @@ (warn "incompatible currencies in monetary+: " a b))) (warn "wrong arguments for monetary+: " a b))) - (define (split->date s) - (xaccTransGetDate (xaccSplitGetParent s))) - - ;; 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 ...) + ;; gets an account alist balances + ;; output: (list acc bal0 bal1 bal2 ...) (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))))))))) + (cons account + (gnc:account-get-balances-at-dates + account dates-list + #:ignore-closing? (gnc:account-is-inc-exp? account)))) ;; This calculates the balances for all the 'account-balances' for ;; each element of the list 'dates'. Uses the collector->monetary @@ -353,7 +295,7 @@ (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 + ;; whereby list of balances are gnc-monetary objects ;; output: (list ) (define list-of-collectors (let loop ((n (length dates)) (result '())) @@ -365,8 +307,8 @@ (list-of-balances (cdar lst))) (when (pair? list-of-balances) ((car list-of-collectors) 'add - (xaccAccountGetCommodity (caar lst)) - (car list-of-balances)) + (gnc:gnc-monetary-commodity (car list-of-balances)) + (gnc:gnc-monetary-amount (car list-of-balances))) (innerloop (cdr list-of-collectors) (cdr list-of-balances)))) (loop (cdr lst)))) list-of-collectors)