From c94db1ac340c69832192d05813e565b4f68db41a Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Thu, 18 Oct 2018 14:10:36 +0800 Subject: [PATCH 01/13] [report-utilities] deprecate flawed function. 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. --- gnucash/report/report-system/report-utilities.scm | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/gnucash/report/report-system/report-utilities.scm b/gnucash/report/report-system/report-utilities.scm index f01a97a4d5..7b3f803b96 100644 --- a/gnucash/report/report-system/report-utilities.scm +++ b/gnucash/report/report-system/report-utilities.scm @@ -386,7 +386,22 @@ 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)))) From 1444a58c0ea0bfc55081dd2d242cdd75a7c883af Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 17 Oct 2018 22:25:53 +0800 Subject: [PATCH 02/13] [report-utilities] upgrade (gnc:account-get-balances-at-dates) (gnc:account-get-balances-at-dates) is upgraded to report-utilities. this function is slightly different to its single-account counterpart because it does not retrieve subaccount amounts. --- .../report/report-system/report-system.scm | 1 + .../report/report-system/report-utilities.scm | 57 +++++++++++++++ .../report/standard-reports/net-charts.scm | 70 ++----------------- 3 files changed, 64 insertions(+), 64 deletions(-) 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 7b3f803b96..de98730e58 100644 --- a/gnucash/report/report-system/report-utilities.scm +++ b/gnucash/report/report-system/report-utilities.scm @@ -406,6 +406,63 @@ flawed. see report-utilities.scm. please update reports.") 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 scheme number +(define* (gnc:account-get-balances-at-dates account dates-list #:key ignore-closing?) + (let loop ((splits (xaccAccountGetSplitList account)) + (dates-list dates-list) + (currentbal 0) + (lastbal 0) + (balancelist '())) + (cond + + ;; end of dates. job done! + ((null? dates-list) + (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/net-charts.scm b/gnucash/report/standard-reports/net-charts.scm index 317a2200ba..ff31e7e9f6 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 From c13f076a331928d583892fd55397623038cbbe42 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Thu, 18 Oct 2018 14:19:07 +0800 Subject: [PATCH 03/13] [report-utilities] modify gnc-account-get-balances-at-dates instead of returning a list of numbers e.g. (list 200 400 600), return a list of gnc-monetary objects (list $200 $400 $600) to be more meaningful. --- gnucash/report/report-system/report-utilities.scm | 6 ++++-- gnucash/report/standard-reports/net-charts.scm | 6 +++--- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/gnucash/report/report-system/report-utilities.scm b/gnucash/report/report-system/report-utilities.scm index de98730e58..e2fa050e93 100644 --- a/gnucash/report/report-system/report-utilities.scm +++ b/gnucash/report/report-system/report-utilities.scm @@ -411,8 +411,10 @@ flawed. see report-utilities.scm. please update reports.") ;; in: account ;; dates-list (list of time64) ;; ignore-closing? - if #true, will skip closing entries -;; out: (list bal0 bal1 ...), each entry is a scheme number +;; 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) @@ -422,7 +424,7 @@ flawed. see report-utilities.scm. please update reports.") ;; end of dates. job done! ((null? dates-list) - (reverse balancelist)) + (map amount->monetary (reverse balancelist))) ;; end of splits, but still has dates. pad with last-bal ;; until end of dates. diff --git a/gnucash/report/standard-reports/net-charts.scm b/gnucash/report/standard-reports/net-charts.scm index ff31e7e9f6..ca8ecb379b 100644 --- a/gnucash/report/standard-reports/net-charts.scm +++ b/gnucash/report/standard-reports/net-charts.scm @@ -295,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 '())) @@ -307,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) From 6c59cd15cdafc490892349127a5af871436f91ec Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 17 Oct 2018 17:52:18 +0800 Subject: [PATCH 04/13] [category-barchart] Deoptimize category-barchart This aims to partially undo commit 8aed5c3f660, and removes dependency unto collectors and report-collectors. --- .../standard-reports/category-barchart.scm | 110 +++++++++++------- 1 file changed, 66 insertions(+), 44 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index ba23a977b8..b3b91298bc 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -24,8 +24,6 @@ ;; 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 gnc-module)) @@ -263,6 +261,8 @@ developing over time")) (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 @@ -285,16 +285,8 @@ developing over time")) (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) @@ -404,6 +396,34 @@ developing over time")) ((list? data) (myor (map not-all-zeros data))) (else #f))) + ;; Calculates the net balance (profit or loss) of an account in + ;; the given time interval. date-list-entry is a pair containing + ;; the start- and end-date of that interval. If subacct?==#t, + ;; the subaccount's balances are included as well. Returns a + ;; double, exchanged into the report-currency by the above + ;; conversion function, and possibly with reversed sign. + (define (get-balance account date-list-entry subacct?) + ((if (reverse-balance? account) + gnc:monetary-neg identity) + (if do-intervals? + (collector->monetary + (gnc:account-get-comm-balance-interval + account + (first date-list-entry) + (second date-list-entry) subacct?) + (second date-list-entry)) + (collector->monetary + (gnc:account-get-comm-balance-at-date + account date-list-entry subacct?) + date-list-entry)))) + +;; Creates the to be used in the function + ;; below. + (define (account->balance-list account subacct?) + (map + (lambda (d) (get-balance account d subacct?)) + dates-list)) + (define (count-accounts current-depth accts) (if (< current-depth tree-depth) (let ((sum 0)) @@ -429,34 +449,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 @@ -476,12 +495,15 @@ developing over time")) commodity-list to-date-t64 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))) + (set! all-data (sort + (filter (lambda (l) + (not (zero? + (gnc:gnc-monetary-amount + (apply monetary+ (cadr l)))))) + (traverse-accounts 1 topl-accounts)) (cond ((eq? sort-method 'acct-code) (lambda (a b) @@ -783,7 +805,7 @@ developing over time")) (gnc:html-document-add-object! document (gnc:html-make-empty-data-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! From f27ea2d4bc57ad559ae9521094db39e0ca7ae1d9 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Fri, 19 Oct 2018 18:23:42 +0800 Subject: [PATCH 05/13] [category-barchart] *reindent/untabify/delete-trailing-whitespace* --- .../standard-reports/category-barchart.scm | 698 +++++++++--------- 1 file changed, 349 insertions(+), 349 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index b3b91298bc..0d8e1efb95 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -25,7 +25,7 @@ ;; depends must be outside module scope -- and should eventually go away. (define-module (gnucash report standard-reports category-barchart)) (use-modules (srfi srfi-1)) -(use-modules (gnucash utilities)) +(use-modules (gnucash utilities)) (use-modules (gnucash gnc-module)) (use-modules (gnucash gettext)) @@ -42,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")) @@ -87,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)))) @@ -101,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) @@ -141,17 +141,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 @@ -161,19 +161,19 @@ 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 @@ -195,11 +195,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) @@ -219,63 +219,63 @@ 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?")) - - (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) + (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))))) - + )) + (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) @@ -294,43 +294,43 @@ 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 - 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)) + (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)) ;; 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-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 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 @@ -343,10 +343,10 @@ developing over time")) (define (datelist->stringlist dates-list) (map (lambda (date-list-item) - (qof-print-date - (if do-intervals? - (car date-list-item) - 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 @@ -361,11 +361,11 @@ developing over time")) report-currency (gnc-numeric-mul (gnc:gnc-monetary-amount - (gnc:sum-collector-commodity + (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) @@ -407,9 +407,9 @@ developing over time")) gnc:monetary-neg identity) (if do-intervals? (collector->monetary - (gnc:account-get-comm-balance-interval - account - (first date-list-entry) + (gnc:account-get-comm-balance-interval + account + (first date-list-entry) (second date-list-entry) subacct?) (second date-list-entry)) (collector->monetary @@ -417,23 +417,23 @@ developing over time")) account date-list-entry subacct?) date-list-entry)))) -;; Creates the to be used in the function - ;; below. + ;; Creates the to be used in the function + ;; below. (define (account->balance-list account subacct?) - (map + (map (lambda (d) (get-balance account d subacct?)) dates-list)) - (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)))) + (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)) @@ -455,10 +455,10 @@ developing over time")) (for-each (lambda (a) (begin - (set! work-done (1+ work-done)) - (gnc:report-percent-done (+ 20 (* 70 (/ work-done work-to-do)))) + (set! work-done (1+ work-done)) + (gnc:report-percent-done (+ 20 (* 70 (/ work-done work-to-do)))) (if (show-acct? a) - (set! res + (set! res (cons (list a (account->balance-list a #f)) res))) (set! res (append @@ -471,11 +471,11 @@ developing over time")) ;; 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)))) + (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 @@ -484,251 +484,251 @@ 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) + (set! all-data (sort + (filter (lambda (l) (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-numeric-compare (gnc:gnc-monetary-amount (apply monetary+ (cadr a))) (gnc:gnc-monetary-amount (apply monetary+ (cadr b)))) 0))) - ))) + ))) ;; 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 + (begin (set! date-string-list (datelist->stringlist dates-list)) (qof-date-format-set QOF-DATE-FORMAT-ISO) (set! date-iso-string-list (datelist->stringlist 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?) - ) - ) - + (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 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 + (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) + (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))) - ) - ) - + (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))) + ) + ) + ;; 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 (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:html-document-add-object! document chart) (if show-table? (begin @@ -753,11 +753,11 @@ developing over time")) (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")) @@ -789,7 +789,7 @@ developing over time")) ) ) ) - ;; set numeric columns to align right + ;; set numeric columns to align right (for-each (lambda (col) (gnc:html-table-set-col-style! @@ -805,28 +805,28 @@ developing over time")) (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 @@ -834,31 +834,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))) From 952ac9c7f40ce209ce3b9976d7edbbc9ba1bdfbe Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Fri, 19 Oct 2018 18:27:19 +0800 Subject: [PATCH 06/13] [category-barchart] compact functions --- .../standard-reports/category-barchart.scm | 105 ++++++------------ 1 file changed, 34 insertions(+), 71 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index 0d8e1efb95..c899649948 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -128,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 @@ -170,10 +167,7 @@ developing over time")) (N_ "Use bar charts.")) (vector 'linechart (N_ "Line Chart") - (N_ "Use line charts.")) - ) - ) - ) + (N_ "Use line charts."))))) (add-option (gnc:make-simple-boolean-option @@ -265,11 +259,9 @@ developing over time")) (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) - )) + (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 @@ -281,7 +273,7 @@ developing over time")) (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)) @@ -300,20 +292,17 @@ developing over time")) (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)) + (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)) - ) + (diff-int-numeric (inexact->exact diff-int))) ;; 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)) + 1)) + 1)) ;; If there is averaging, the report-title is extended ;; accordingly. (report-title @@ -355,8 +344,6 @@ developing over time")) ;; 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 @@ -364,8 +351,7 @@ developing over time")) (gnc:sum-collector-commodity c report-currency (lambda (a b) (exchange-fn a b date)))) - averaging-multiplier currency-frac GNC-RND-ROUND) - )) + averaging-multiplier currency-frac GNC-RND-ROUND))) ;; Add two or more gnc-monetary objects (define (monetary+ a . blist) @@ -378,9 +364,7 @@ developing over time")) (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))) - ) - ) + (warn "wrong arguments for monetary+: " a b))))) ;; Extract value of gnc-monetary and return it as double (define (monetary->double monetary) @@ -429,7 +413,7 @@ developing over time")) (let ((sum 0)) (for-each (lambda (a) - (set! sum (+ sum (+ 1 (count-accounts (+ 1 current-depth) + (set! sum (+ sum (+ 1 (count-accounts (1+ current-depth) (gnc-account-get-children a)))))) accts) sum) @@ -463,7 +447,7 @@ developing over time")) res))) (set! res (append (traverse-accounts - (+ 1 current-depth) + (1+ current-depth) (gnc-account-get-children a)) res)))) accts) @@ -543,7 +527,7 @@ developing over time")) (set! date-iso-string-list (datelist->stringlist dates-list)) (qof-date-format-set save-fmt) ;; Set chart title, subtitle etc. - (if (eqv? chart-type 'barchart) + (if (eq? chart-type 'barchart) (begin (gnc:html-barchart-set-title! chart report-title) (gnc:html-barchart-set-subtitle! @@ -551,8 +535,8 @@ developing over time")) (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)))) + (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) @@ -577,8 +561,8 @@ developing over time")) (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)))) + (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) @@ -602,8 +586,8 @@ developing over time")) ;; '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))) + (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))))) @@ -629,7 +613,7 @@ developing over time")) ;; 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) + (if (eq? chart-type 'barchart) (begin ;; bar chart (if (not (null? all-data)) (gnc:html-barchart-set-data! @@ -650,8 +634,7 @@ developing over time")) all-data)) (gnc:html-barchart-set-col-colors! chart - (gnc:assign-colors (length all-data))) - ) + (gnc:assign-colors (length all-data)))) (begin ;; line chart (if (not (null? all-data)) (gnc:html-linechart-set-data! @@ -672,9 +655,7 @@ developing over time")) all-data)) (gnc:html-linechart-set-col-colors! chart - (gnc:assign-colors (length all-data))) - ) - ) + (gnc:assign-colors (length all-data))))) ;; set the URLs; the slices are links to other reports ;; (gnc:report-percent-done 96) @@ -703,14 +684,14 @@ developing over time")) ;; (list gnc:pagename-accounts optname-accounts ;; (cons acct subaccts)) ;; (list gnc:pagename-accounts optname-levels - ;; (+ 1 tree-depth)) + ;; (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) + ;; (if (eq? chart-type 'barchart) ;; (begin ;; bar chart ;; (gnc:html-barchart-set-button-1-bar-urls! ;; chart (append urls urls)) @@ -741,12 +722,8 @@ 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 @@ -761,9 +738,7 @@ developing over time")) all-data) (if (> (gnc:html-table-num-columns table) 2) (list (_ "Grand Total")) - '() - ) - )) + '()))) (if (> (gnc:html-table-num-columns table) 2) (letrec @@ -771,24 +746,15 @@ 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 (gnc-numeric-zero)))))) (gnc:html-table-append-column! table - (sumtot (apply zip (map cadr all-data))) - ) - ) - ) + (sumtot (apply zip (map cadr all-data)))))) ;; set numeric columns to align right (for-each (lambda (col) @@ -796,10 +762,7 @@ developing over time")) 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! From d318fff9a5fa7a26259eb6c4d5a107df55adcaf9 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Fri, 19 Oct 2018 18:29:16 +0800 Subject: [PATCH 07/13] [category-barchart] remove old gnc-numeric methods --- .../standard-reports/category-barchart.scm | 35 +++++++++---------- 1 file changed, 16 insertions(+), 19 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index c899649948..84722f70f9 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -290,17 +290,17 @@ developing over time")) ;; 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))) + (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))) + (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) - (gnc-numeric-div diff-int-numeric diff-avg-numeric GNC-DENOM-AUTO GNC-RND-ROUND) + (/ diff-int-numeric diff-avg-numeric) 1)) 1)) ;; If there is averaging, the report-title is extended @@ -346,12 +346,11 @@ developing over time")) (define (collector->monetary c date) (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))) + (* averaging-multiplier + (gnc:gnc-monetary-amount + (gnc:sum-collector-commodity + c report-currency + (lambda (a b) (exchange-fn a b date))))))) ;; Add two or more gnc-monetary objects (define (monetary+ a . blist) @@ -360,7 +359,7 @@ developing over time")) (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))) + (amount (+ (gnc:gnc-monetary-amount a) (gnc:gnc-monetary-amount b)))) (if same-currency? (gnc:make-gnc-monetary (gnc:gnc-monetary-commodity a) amount) (warn "incompatible currencies in monetary+: " a b))) @@ -368,7 +367,7 @@ developing over time")) ;; Extract value of gnc-monetary and return it as double (define (monetary->double monetary) - (gnc-numeric-to-double (gnc:gnc-monetary-amount monetary))) + (gnc:gnc-monetary-amount monetary)) ;; copy of gnc:not-all-zeros using gnc-monetary (define (not-all-zeros data) @@ -376,7 +375,7 @@ developing over time")) (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)))) + (cond ((gnc:gnc-monetary? data) (not (zero? (gnc:gnc-monetary-amount data)))) ((list? data) (myor (map not-all-zeros data))) (else #f))) @@ -413,8 +412,8 @@ developing over time")) (let ((sum 0)) (for-each (lambda (a) - (set! sum (+ sum (+ 1 (count-accounts (1+ current-depth) - (gnc-account-get-children a)))))) + (set! sum (+ sum (1+ (count-accounts (1+ current-depth) + (gnc-account-get-children a)))))) accts) sum) (length (filter show-acct? accts)))) @@ -503,10 +502,8 @@ developing over time")) xaccAccountGetName) (car b))))) (else (lambda (a b) - (> (gnc-numeric-compare (gnc:gnc-monetary-amount (apply monetary+ (cadr a))) - (gnc:gnc-monetary-amount (apply monetary+ (cadr b)))) - 0))) - ))) + (> (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 b)))))) @@ -751,7 +748,7 @@ developing over time")) (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)))))) From 4091ea8ea9bfe0ec897b05c7e0666655a13d6ff1 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Fri, 19 Oct 2018 18:30:13 +0800 Subject: [PATCH 08/13] [category-barchart] rewrite monetary+ using commodity collector This is neater. Split into 2 functions, both of which are useful (monetaries-add . monetaries) add different gnc-monetary objects into a gnc-commodity-collector (monetaries+ . monetaries) special case for above whereby all monetaries are expected to be in one currency only -- convert gnc-commodity-collector to monetary --- .../standard-reports/category-barchart.scm | 26 ++++++++++--------- 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index 84722f70f9..049fd0f915 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -352,18 +352,20 @@ developing over time")) c report-currency (lambda (a b) (exchange-fn a b date))))))) - ;; 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:gnc-monetary-amount a) (gnc:gnc-monetary-amount b)))) - (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))))) + (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))))) ;; Extract value of gnc-monetary and return it as double (define (monetary->double monetary) From 9a179f8293fda7c94102213a491ff5c019d15eb5 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Fri, 19 Oct 2018 18:31:30 +0800 Subject: [PATCH 09/13] [category-barchart] remove monetary->double doubles are not necessary for charts. --- gnucash/report/standard-reports/category-barchart.scm | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index 049fd0f915..e219531cb1 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -367,10 +367,6 @@ developing over time")) (car (coll 'format gnc:make-gnc-monetary #f)) (gnc:warn "monetary+ expects 1 currency " (gnc:strify monetaries))))) - ;; Extract value of gnc-monetary and return it as double - (define (monetary->double monetary) - (gnc:gnc-monetary-amount monetary)) - ;; copy of gnc:not-all-zeros using gnc-monetary (define (not-all-zeros data) (define (myor list) @@ -618,7 +614,7 @@ developing over time")) (gnc:html-barchart-set-data! chart (apply zip (map (lambda (mlist) - (map monetary->double mlist)) + (map gnc:gnc-monetary-amount mlist)) (map cadr all-data))))) ;; Labels and colors @@ -639,7 +635,7 @@ developing over time")) (gnc:html-linechart-set-data! chart (apply zip (map (lambda (mlist) - (map monetary->double mlist)) + (map gnc:gnc-monetary-amount mlist)) (map cadr all-data))))) ;; Labels and colors From d8b8c197bcfd76dd9ad0a623c6e4c75730127b7e Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Fri, 19 Oct 2018 18:32:31 +0800 Subject: [PATCH 10/13] [category-barchart] use (or-map) in (not-all-zeros) --- gnucash/report/standard-reports/category-barchart.scm | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index e219531cb1..ba8818eadb 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -369,12 +369,8 @@ developing over time")) ;; 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 (zero? (gnc:gnc-monetary-amount data)))) - ((list? data) (myor (map not-all-zeros data))) + ((list? data) (or-map not-all-zeros data)) (else #f))) ;; Calculates the net balance (profit or loss) of an account in From de343aac3d15d0cb483f1f0e6a527f8d96d49974 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Fri, 19 Oct 2018 18:35:10 +0800 Subject: [PATCH 11/13] [category-barchart] optimize (account->balance-list) 1. Modify dates-list definition instead of either (list date0 date1 date) or (list (list start0 end0 '()) (list start1 end1 '()) ...) it now is a list-of-dates (list date0 date1 date2) 2. Pre-generate account-balances using dates-list. account-balances-alist is an alist-of-balances 3. Use the pre-generated account-balance-alist instead of calling (get-balance) to obtain balances. This bypasses (get-balance) which calls a very expensive query-based functions for every *account* and *date-interval* --- .../standard-reports/category-barchart.scm | 79 ++++++++++++++----- 1 file changed, 60 insertions(+), 19 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index ba8818eadb..41bf399d65 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -313,15 +313,12 @@ developing over time")) (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 '()) @@ -331,12 +328,7 @@ developing over time")) (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)) + (map qof-print-date dates-list)) ;; Converts a commodity-collector into gnc-monetary in the report's ;; currency using the exchange-fn calculated above. Returns a gnc-monetary @@ -367,12 +359,34 @@ developing over time")) (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) (cond ((gnc:gnc-monetary? data) (not (zero? (gnc:gnc-monetary-amount data)))) ((list? data) (or-map not-all-zeros data)) (else #f))) + ;; 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)) + ;; Calculates the net balance (profit or loss) of an account in ;; the given time interval. date-list-entry is a pair containing ;; the start- and end-date of that interval. If subacct?==#t, @@ -397,9 +411,34 @@ developing over time")) ;; Creates the to be used in the function ;; below. (define (account->balance-list account subacct?) - (map - (lambda (d) (get-balance account d subacct?)) - dates-list)) + (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) @@ -512,7 +551,9 @@ developing over time")) (if (and (not (null? all-data)) (not-all-zeros (map cadr all-data))) - (begin + (let ((dates-list (if do-intervals? + (list-head dates-list (1- (length dates-list))) + dates-list))) (set! date-string-list (datelist->stringlist dates-list)) (qof-date-format-set QOF-DATE-FORMAT-ISO) (set! date-iso-string-list (datelist->stringlist dates-list)) From af5fb0dde5b53e541fc181f2d237220b34fc2902 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Sun, 28 Oct 2018 15:17:28 +0800 Subject: [PATCH 12/13] [category-barchart] remove datelist->stringlist --- gnucash/report/standard-reports/category-barchart.scm | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index 41bf399d65..283b0c5681 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -327,9 +327,6 @@ developing over time")) (other-anchor "") (all-data '())) - (define (datelist->stringlist dates-list) - (map qof-print-date 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 @@ -554,9 +551,9 @@ developing over time")) (let ((dates-list (if do-intervals? (list-head dates-list (1- (length dates-list))) dates-list))) - (set! date-string-list (datelist->stringlist 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 (eq? chart-type 'barchart) From cef574affeb753e3faab2604a0cbd79a58bddb21 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Fri, 19 Oct 2018 18:35:30 +0800 Subject: [PATCH 13/13] [category-barchart] remove old expensive function --- .../standard-reports/category-barchart.scm | 21 ------------------- 1 file changed, 21 deletions(-) diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm index 283b0c5681..10181aec96 100644 --- a/gnucash/report/standard-reports/category-barchart.scm +++ b/gnucash/report/standard-reports/category-barchart.scm @@ -384,27 +384,6 @@ developing over time")) #:ignore-closing? (gnc:account-is-inc-exp? acc))))) accounts)) - ;; Calculates the net balance (profit or loss) of an account in - ;; the given time interval. date-list-entry is a pair containing - ;; the start- and end-date of that interval. If subacct?==#t, - ;; the subaccount's balances are included as well. Returns a - ;; double, exchanged into the report-currency by the above - ;; conversion function, and possibly with reversed sign. - (define (get-balance account date-list-entry subacct?) - ((if (reverse-balance? account) - gnc:monetary-neg identity) - (if do-intervals? - (collector->monetary - (gnc:account-get-comm-balance-interval - account - (first date-list-entry) - (second date-list-entry) subacct?) - (second date-list-entry)) - (collector->monetary - (gnc:account-get-comm-balance-at-date - account date-list-entry subacct?) - date-list-entry)))) - ;; Creates the to be used in the function ;; below. (define (account->balance-list account subacct?)