mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
[category-barchart] refactor, handling error conditions first
This commit is contained in:
Christopher Lam
parent
e6b97849a5
commit
6605a6eb66
@ -274,417 +274,394 @@ developing over time"))
|
|||||||
account-levels))
|
account-levels))
|
||||||
|
|
||||||
;;(gnc:debug accounts)
|
;;(gnc:debug accounts)
|
||||||
(if (not (null? accounts))
|
(cond
|
||||||
|
((null? accounts)
|
||||||
|
(gnc:html-document-add-object!
|
||||||
|
document
|
||||||
|
(gnc:html-make-no-account-warning
|
||||||
|
report-title (gnc:report-id report-obj))))
|
||||||
|
|
||||||
;; Define more helper variables.
|
(else
|
||||||
(let* ((commodity-list #f)
|
(let* ((commodity-list (gnc:accounts-get-commodities
|
||||||
(exchange-fn #f)
|
(gnc:accounts-and-all-descendants accounts)
|
||||||
(averaging-fraction-func (gnc:date-get-fraction-func averaging-selection))
|
report-currency))
|
||||||
(interval-fraction-func (gnc:date-get-fraction-func interval))
|
(exchange-fn (gnc:case-exchange-time-fn
|
||||||
(averaging-multiplier
|
price-source report-currency
|
||||||
(if averaging-fraction-func
|
commodity-list to-date-t64
|
||||||
;; Calculate the divisor of the amounts so that an
|
5 15))
|
||||||
;; average is shown. Multiplier factor is a gnc-numeric
|
(averaging-fraction-func (gnc:date-get-fraction-func averaging-selection))
|
||||||
(let* ((start-frac-avg (averaging-fraction-func from-date-t64))
|
(interval-fraction-func (gnc:date-get-fraction-func interval))
|
||||||
(end-frac-avg (averaging-fraction-func (1+ to-date-t64)))
|
(averaging-multiplier
|
||||||
(diff-avg (- end-frac-avg start-frac-avg))
|
(if averaging-fraction-func
|
||||||
(diff-avg-numeric (/ (inexact->exact (round (* diff-avg 1000000))) ; 6 decimals precision
|
;; Calculate the divisor of the amounts so that an
|
||||||
1000000))
|
;; average is shown. Multiplier factor is a gnc-numeric
|
||||||
(start-frac-int (interval-fraction-func from-date-t64))
|
(let* ((start-frac-avg (averaging-fraction-func from-date-t64))
|
||||||
(end-frac-int (interval-fraction-func (1+ to-date-t64)))
|
(end-frac-avg (averaging-fraction-func (1+ to-date-t64)))
|
||||||
(diff-int (- end-frac-int start-frac-int))
|
(diff-avg (- end-frac-avg start-frac-avg))
|
||||||
(diff-int-numeric (inexact->exact diff-int)))
|
(diff-avg-numeric
|
||||||
;; Extra sanity check to ensure a number smaller than 1
|
(/ (inexact->exact (round (* diff-avg 1000000)))
|
||||||
(if (> diff-avg diff-int)
|
;; 6 decimals precision
|
||||||
(/ diff-int-numeric diff-avg-numeric)
|
1000000))
|
||||||
1))
|
(start-frac-int (interval-fraction-func from-date-t64))
|
||||||
1))
|
(end-frac-int (interval-fraction-func (1+ to-date-t64)))
|
||||||
;; If there is averaging, the report-title is extended
|
(diff-int (- end-frac-int start-frac-int))
|
||||||
;; accordingly.
|
(diff-int-numeric (inexact->exact diff-int)))
|
||||||
(report-title
|
;; Extra sanity check to ensure a number smaller than 1
|
||||||
(case averaging-selection
|
(if (> diff-avg diff-int)
|
||||||
((MonthDelta) (string-append report-title " " (G_ "Monthly Average")))
|
(/ diff-int-numeric diff-avg-numeric)
|
||||||
((WeekDelta) (string-append report-title " " (G_ "Weekly Average")))
|
1))
|
||||||
((DayDelta) (string-append report-title " " (G_ "Daily Average")))
|
1))
|
||||||
(else report-title)))
|
;; If there is averaging, the report-title is extended
|
||||||
(currency-frac (gnc-commodity-get-fraction report-currency))
|
;; accordingly.
|
||||||
;; This is the list of date intervals to calculate.
|
(report-title
|
||||||
(dates-list (gnc:make-date-list
|
(case averaging-selection
|
||||||
((if do-intervals?
|
((MonthDelta) (string-append report-title " " (G_ "Monthly Average")))
|
||||||
gnc:time64-start-day-time
|
((WeekDelta) (string-append report-title " " (G_ "Weekly Average")))
|
||||||
gnc:time64-end-day-time) from-date-t64)
|
((DayDelta) (string-append report-title " " (G_ "Daily Average")))
|
||||||
(gnc:time64-end-day-time to-date-t64)
|
(else report-title)))
|
||||||
(gnc:deltasym-to-delta interval)))
|
(currency-frac (gnc-commodity-get-fraction report-currency))
|
||||||
;; Here the date strings for the x-axis labels are
|
;; This is the list of date intervals to calculate.
|
||||||
;; created.
|
(dates-list (gnc:make-date-list
|
||||||
(other-anchor "")
|
((if do-intervals?
|
||||||
(all-data '()))
|
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.
|
||||||
|
(other-anchor ""))
|
||||||
|
|
||||||
;; Converts a commodity-collector into gnc-monetary in the report's
|
;; Converts a commodity-collector into gnc-monetary in the report's
|
||||||
;; currency using the exchange-fn calculated above. Returns a gnc-monetary
|
;; currency using the exchange-fn calculated above. Returns a gnc-monetary
|
||||||
;; multiplied by the averaging-multiplier (smaller than one; multiplication
|
;; multiplied by the averaging-multiplier (smaller than one; multiplication
|
||||||
;; instead of division to avoid division-by-zero issues) in case
|
;; instead of division to avoid division-by-zero issues) in case
|
||||||
;; the user wants to see the amounts averaged over some value.
|
;; the user wants to see the amounts averaged over some value.
|
||||||
(define (collector->monetary c date)
|
(define (collector->monetary c date)
|
||||||
(gnc:make-gnc-monetary
|
(gnc:make-gnc-monetary
|
||||||
report-currency
|
report-currency
|
||||||
(* averaging-multiplier
|
(* averaging-multiplier
|
||||||
(gnc:gnc-monetary-amount
|
(gnc:gnc-monetary-amount
|
||||||
(gnc:sum-collector-commodity
|
(gnc:sum-collector-commodity
|
||||||
c report-currency
|
c report-currency
|
||||||
(lambda (a b) (exchange-fn a b date)))))))
|
(lambda (a b) (exchange-fn a b date)))))))
|
||||||
|
|
||||||
;; copy of gnc:not-all-zeros using gnc-monetary
|
(define (all-zeros data)
|
||||||
(define (not-all-zeros data)
|
(cond
|
||||||
(cond ((gnc:gnc-monetary? data) (not (zero? (gnc:gnc-monetary-amount data))))
|
((gnc:gnc-monetary? data) (zero? (gnc:gnc-monetary-amount data)))
|
||||||
((list? data) (or-map not-all-zeros data))
|
((pair? data) (every all-zeros data))
|
||||||
(else #f)))
|
(else (error 'huh))))
|
||||||
|
|
||||||
;; this is an alist of account-balances
|
;; this is an alist of account-balances
|
||||||
;; (list (list acc0 bal0 bal1 bal2 ...)
|
;; (list (list acc0 bal0 bal1 bal2 ...)
|
||||||
;; (list acc1 bal0 bal1 bal2 ...)
|
;; (list acc1 bal0 bal1 bal2 ...)
|
||||||
;; ...)
|
;; ...)
|
||||||
;; whereby each balance is a gnc-monetary
|
;; whereby each balance is a gnc-monetary
|
||||||
(define account-balances-alist
|
(define account-balances-alist
|
||||||
(map
|
(map
|
||||||
(lambda (acc)
|
(lambda (acc)
|
||||||
(let* ((comm (xaccAccountGetCommodity acc))
|
(let* ((comm (xaccAccountGetCommodity acc))
|
||||||
(split->elt (if reverse-bal?
|
(split->elt (if reverse-bal?
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
(gnc:make-gnc-monetary
|
(gnc:make-gnc-monetary
|
||||||
comm (- (xaccSplitGetNoclosingBalance s))))
|
comm (- (xaccSplitGetNoclosingBalance s))))
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
(gnc:make-gnc-monetary
|
(gnc:make-gnc-monetary
|
||||||
comm (xaccSplitGetNoclosingBalance s))))))
|
comm (xaccSplitGetNoclosingBalance s))))))
|
||||||
(cons acc
|
(cons acc
|
||||||
(gnc:account-accumulate-at-dates
|
(gnc:account-accumulate-at-dates
|
||||||
acc dates-list
|
acc dates-list
|
||||||
#:split->elt split->elt
|
#:split->elt split->elt
|
||||||
#:nosplit->elt (gnc:make-gnc-monetary comm 0)))))
|
#:nosplit->elt (gnc:make-gnc-monetary comm 0)))))
|
||||||
;; all selected accounts (of report-specific type), *and*
|
;; all selected accounts (of report-specific type), *and*
|
||||||
;; their descendants (of any type) need to be scanned.
|
;; their descendants (of any type) need to be scanned.
|
||||||
(gnc:accounts-and-all-descendants accounts)))
|
(gnc:accounts-and-all-descendants accounts)))
|
||||||
|
|
||||||
;; Creates the <balance-list> to be used in the function
|
;; Creates the <balance-list> to be used in the function
|
||||||
;; below.
|
;; below.
|
||||||
(define (account->balance-list account subacct?)
|
(define (account->balance-list account subacct?)
|
||||||
(let* ((accountslist (cons account
|
(let* ((accountslist (cons account
|
||||||
(if subacct?
|
(if subacct?
|
||||||
(gnc-account-get-descendants account)
|
(gnc-account-get-descendants account)
|
||||||
'())))
|
'())))
|
||||||
(selected-balances (filter
|
(selected-balances (filter
|
||||||
(lambda (entry)
|
(lambda (entry)
|
||||||
(member (car entry) accountslist))
|
(member (car entry) accountslist))
|
||||||
account-balances-alist))
|
account-balances-alist))
|
||||||
(selected-monetaries (map cdr selected-balances))
|
(selected-monetaries (map cdr selected-balances))
|
||||||
(list-of-mon-collectors (apply map gnc:monetaries-add selected-monetaries)))
|
(list-of-mon-collectors (apply map gnc:monetaries-add selected-monetaries)))
|
||||||
(let loop ((list-of-mon-collectors list-of-mon-collectors)
|
(let loop ((list-of-mon-collectors list-of-mon-collectors)
|
||||||
(dates-list dates-list)
|
(dates-list dates-list)
|
||||||
(result '()))
|
(result '()))
|
||||||
(if (null? (if do-intervals?
|
(if (null? (if do-intervals?
|
||||||
(cdr list-of-mon-collectors)
|
(cdr list-of-mon-collectors)
|
||||||
list-of-mon-collectors))
|
list-of-mon-collectors))
|
||||||
(reverse result)
|
(reverse result)
|
||||||
(loop (cdr list-of-mon-collectors)
|
(loop (cdr list-of-mon-collectors)
|
||||||
(cdr dates-list)
|
(cdr dates-list)
|
||||||
(cons (if do-intervals?
|
(cons (if do-intervals?
|
||||||
(collector->monetary
|
(collector->monetary
|
||||||
(gnc:collector- (cadr list-of-mon-collectors)
|
(gnc:collector- (cadr list-of-mon-collectors)
|
||||||
(car list-of-mon-collectors))
|
(car list-of-mon-collectors))
|
||||||
(cadr dates-list))
|
(cadr dates-list))
|
||||||
(collector->monetary
|
(collector->monetary
|
||||||
(car list-of-mon-collectors)
|
(car list-of-mon-collectors)
|
||||||
(car dates-list)))
|
(car dates-list)))
|
||||||
result))))))
|
result))))))
|
||||||
|
|
||||||
(define (count-accounts current-depth accts)
|
(define (count-accounts current-depth accts)
|
||||||
(if (< current-depth tree-depth)
|
(if (< current-depth tree-depth)
|
||||||
(let ((sum 0))
|
(let ((sum 0))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (a)
|
(lambda (a)
|
||||||
(set! sum (+ sum (1+ (count-accounts (1+ current-depth)
|
(set! sum
|
||||||
(gnc-account-get-children a))))))
|
(+ sum (1+ (count-accounts (1+ current-depth)
|
||||||
accts)
|
(gnc-account-get-children a))))))
|
||||||
sum)
|
accts)
|
||||||
(length (filter show-acct? accts))))
|
sum)
|
||||||
|
(length (filter show-acct? accts))))
|
||||||
|
|
||||||
;; Calculates all account's balances. Returns a list of pairs:
|
(set! work-to-do (count-accounts 1 topl-accounts))
|
||||||
;; (<account> <balance-list>), like '((Earnings (10.0 11.2))
|
|
||||||
;; (Gifts (12.3 14.5))), where each element of <balance-list>
|
;; Calculates all account's balances. Returns a list of pairs:
|
||||||
;; is the balance corresponding to one element in
|
;; (<account> <balance-list>), like '((Earnings (10.0 11.2))
|
||||||
;; <dates-list>.
|
;; (Gifts (12.3 14.5))), where each element of <balance-list>
|
||||||
;;
|
;; is the balance corresponding to one element in
|
||||||
;; If current-depth >= tree-depth, then the balances are
|
;; <dates-list>.
|
||||||
;; calculated *with* subaccount's balances. Else only the
|
;;
|
||||||
;; current account is regarded. Note: All accounts in accts
|
;; If current-depth >= tree-depth, then the balances are
|
||||||
;; and all their subaccounts are processed, but a balances is
|
;; calculated *with* subaccount's balances. Else only the
|
||||||
;; calculated and returned *only* for those accounts where
|
;; current account is regarded. Note: All accounts in accts
|
||||||
;; show-acct? is true. This is necessary because otherwise we
|
;; and all their subaccounts are processed, but a balances is
|
||||||
;; would forget an account that is selected but not its
|
;; calculated and returned *only* for those accounts where
|
||||||
;; parent.
|
;; show-acct? is true. This is necessary because otherwise we
|
||||||
(define (traverse-accounts current-depth accts)
|
;; would forget an account that is selected but not its
|
||||||
(if (< current-depth tree-depth)
|
;; parent.
|
||||||
(let ((res '()))
|
(define (traverse-accounts current-depth accts)
|
||||||
(for-each
|
(if (< current-depth tree-depth)
|
||||||
(lambda (a)
|
(let ((res '()))
|
||||||
(begin
|
(for-each
|
||||||
(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)
|
(lambda (a)
|
||||||
(set! work-done (1+ work-done))
|
(set! work-done (1+ work-done))
|
||||||
(gnc:report-percent-done (+ 20 (* 70 (/ work-done work-to-do))))
|
(gnc:report-percent-done (+ 20 (* 70 (/ work-done work-to-do))))
|
||||||
(list a (account->balance-list a #t)))
|
(if (show-acct? a)
|
||||||
(filter show-acct? accts))))
|
(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))))
|
||||||
|
|
||||||
|
;; Sort the account list according to the account code field.
|
||||||
|
(define all-data
|
||||||
|
(sort
|
||||||
|
(filter (lambda (l)
|
||||||
|
(not (zero? (gnc:gnc-monetary-amount
|
||||||
|
(apply gnc:monetary+ (cadr l))))))
|
||||||
|
(traverse-accounts 1 topl-accounts))
|
||||||
|
(case sort-method
|
||||||
|
((alphabetical)
|
||||||
|
(lambda (a b)
|
||||||
|
(if show-fullname?
|
||||||
|
(gnc:string-locale<? (gnc-account-get-full-name (car a))
|
||||||
|
(gnc-account-get-full-name (car b)))
|
||||||
|
(gnc:string-locale<? (xaccAccountGetName (car a))
|
||||||
|
(xaccAccountGetName (car b))))))
|
||||||
|
((acct-code)
|
||||||
|
(lambda (a b)
|
||||||
|
(gnc:string-locale<? (xaccAccountGetCode (car a))
|
||||||
|
(xaccAccountGetCode (car b)))))
|
||||||
|
((amount)
|
||||||
|
(lambda (a b)
|
||||||
|
(> (gnc:gnc-monetary-amount (apply gnc:monetary+ (cadr a)))
|
||||||
|
(gnc:gnc-monetary-amount (apply gnc:monetary+ (cadr b)))))))))
|
||||||
|
|
||||||
;; The percentage done numbers here are a hack so that
|
(cond
|
||||||
;; something gets displayed. On my system the
|
((or (null? all-data) (all-zeros (map cadr all-data)))
|
||||||
;; gnc:case-exchange-time-fn takes about 20% of the time
|
(gnc:html-document-add-object!
|
||||||
;; building up a list of prices for later use. Either this
|
document
|
||||||
;; routine needs to send progress reports, or the price
|
(gnc:html-make-empty-data-warning
|
||||||
;; lookup should be distributed and done when actually
|
report-title (gnc:report-id report-obj))))
|
||||||
;; needed so as to amortize the cpu time properly.
|
|
||||||
(gnc:report-percent-done 1)
|
|
||||||
(set! commodity-list (gnc:accounts-get-commodities
|
|
||||||
(gnc:accounts-and-all-descendants accounts)
|
|
||||||
report-currency))
|
|
||||||
(set! exchange-fn (gnc:case-exchange-time-fn
|
|
||||||
price-source report-currency
|
|
||||||
commodity-list to-date-t64
|
|
||||||
5 15))
|
|
||||||
|
|
||||||
(set! work-to-do (count-accounts 1 topl-accounts))
|
(else
|
||||||
|
(let* ((dates-list (if do-intervals?
|
||||||
|
(list-head dates-list (1- (length dates-list)))
|
||||||
|
dates-list))
|
||||||
|
(date-string-list (map qof-print-date dates-list)))
|
||||||
|
|
||||||
;; Sort the account list according to the account code field.
|
;; Set chart title, subtitle etc.
|
||||||
(set! all-data
|
(gnc:html-chart-set-type!
|
||||||
(sort
|
chart (if (eq? chart-type 'barchart) 'bar 'line))
|
||||||
(filter (lambda (l)
|
|
||||||
(not (zero? (gnc:gnc-monetary-amount
|
|
||||||
(apply gnc:monetary+ (cadr l))))))
|
|
||||||
(traverse-accounts 1 topl-accounts))
|
|
||||||
(case sort-method
|
|
||||||
((alphabetical)
|
|
||||||
(lambda (a b)
|
|
||||||
(if show-fullname?
|
|
||||||
(gnc:string-locale<? (gnc-account-get-full-name (car a))
|
|
||||||
(gnc-account-get-full-name (car b)))
|
|
||||||
(gnc:string-locale<? (xaccAccountGetName (car a))
|
|
||||||
(xaccAccountGetName (car b))))))
|
|
||||||
((acct-code)
|
|
||||||
(lambda (a b)
|
|
||||||
(gnc:string-locale<? (xaccAccountGetCode (car a))
|
|
||||||
(xaccAccountGetCode (car b)))))
|
|
||||||
((amount)
|
|
||||||
(lambda (a b)
|
|
||||||
(> (gnc:gnc-monetary-amount (apply gnc:monetary+ (cadr a)))
|
|
||||||
(gnc:gnc-monetary-amount (apply gnc:monetary+ (cadr b)))))))))
|
|
||||||
|
|
||||||
;; Proceed if the data is non-zeros
|
(gnc:html-chart-set-title!
|
||||||
(if
|
chart (list report-title
|
||||||
(and (not (null? all-data))
|
(format #f
|
||||||
(not-all-zeros (map cadr all-data)))
|
(if do-intervals?
|
||||||
|
(G_ "~a to ~a")
|
||||||
|
(G_ "Balances ~a to ~a"))
|
||||||
|
(qof-print-date from-date-t64)
|
||||||
|
(qof-print-date to-date-t64))))
|
||||||
|
|
||||||
(let* ((dates-list (if do-intervals?
|
(gnc:html-chart-set-width! chart width)
|
||||||
(list-head dates-list (1- (length dates-list)))
|
(gnc:html-chart-set-height! chart height)
|
||||||
dates-list))
|
|
||||||
(date-string-list (map qof-print-date dates-list)))
|
|
||||||
|
|
||||||
;; Set chart title, subtitle etc.
|
(gnc:html-chart-set-data-labels! chart date-string-list)
|
||||||
|
(gnc:html-chart-set-y-axis-label!
|
||||||
|
chart (gnc-commodity-get-mnemonic report-currency))
|
||||||
|
|
||||||
(gnc:html-chart-set-type!
|
;; If we have too many categories, we sum them into a new
|
||||||
chart (if (eq? chart-type 'barchart) 'bar 'line))
|
;; '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 (1- max-slices)))
|
||||||
|
(finish (drop all-data (1- max-slices)))
|
||||||
|
(other-sum (map
|
||||||
|
(lambda (l) (apply gnc:monetary+ l))
|
||||||
|
(apply zip (map cadr finish)))))
|
||||||
|
(set! all-data
|
||||||
|
(append start
|
||||||
|
(list (list (G_ "Other") other-sum))))
|
||||||
|
(let* ((options (gnc:make-report-options reportguid)))
|
||||||
|
;; now copy all the options
|
||||||
|
(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
|
||||||
|
optname-accounts)
|
||||||
|
(map car finish))
|
||||||
|
;; Set the URL to point to this report.
|
||||||
|
(set! other-anchor
|
||||||
|
(gnc:report-anchor-text
|
||||||
|
(gnc:make-report reportguid options))))))
|
||||||
|
|
||||||
(gnc:html-chart-set-title!
|
(gnc:report-percent-done 92)
|
||||||
chart (list report-title
|
|
||||||
(format #f
|
|
||||||
(if do-intervals?
|
|
||||||
(G_ "~a to ~a")
|
|
||||||
(G_ "Balances ~a to ~a"))
|
|
||||||
(qof-print-date from-date-t64)
|
|
||||||
(qof-print-date to-date-t64))))
|
|
||||||
|
|
||||||
(gnc:html-chart-set-width! chart width)
|
(for-each
|
||||||
(gnc:html-chart-set-height! chart height)
|
(lambda (series color stack)
|
||||||
|
(let* ((acct (car series))
|
||||||
|
(label (cond
|
||||||
|
((string? acct) (car series))
|
||||||
|
(show-fullname? (gnc-account-get-full-name acct))
|
||||||
|
(else (xaccAccountGetName acct))))
|
||||||
|
(amounts (map gnc:gnc-monetary-amount (cadr series)))
|
||||||
|
(stack (if stacked? "default" (number->string stack)))
|
||||||
|
(fill (eq? chart-type 'barchart))
|
||||||
|
(urls (cond
|
||||||
|
((string? acct) other-anchor)
|
||||||
|
((null? (gnc-account-get-children acct))
|
||||||
|
(gnc:account-anchor-text acct))
|
||||||
|
|
||||||
(gnc:html-chart-set-data-labels! chart date-string-list)
|
;; because the tree-depth option for
|
||||||
(gnc:html-chart-set-y-axis-label!
|
;; accounts/levels goes up to 6. FIXME:
|
||||||
chart (gnc-commodity-get-mnemonic report-currency))
|
;; magic number.
|
||||||
|
((>= tree-depth 6) (gnc:account-anchor-text acct))
|
||||||
|
|
||||||
;; If we have too many categories, we sum them into a new
|
(else
|
||||||
;; 'other' category and add a link to a new report with just
|
(gnc:make-report-anchor
|
||||||
;; those accounts.
|
reportguid report-obj
|
||||||
(if (> (length all-data) max-slices)
|
(list
|
||||||
(let* ((start (take all-data (1- max-slices)))
|
(list gnc:pagename-accounts optname-accounts
|
||||||
(finish (drop all-data (1- max-slices)))
|
(cons acct (gnc-account-get-children acct)))
|
||||||
(other-sum (map
|
(list gnc:pagename-accounts optname-levels
|
||||||
(lambda (l) (apply gnc:monetary+ l))
|
(1+ tree-depth))
|
||||||
(apply zip (map cadr finish)))))
|
(list gnc:pagename-general
|
||||||
(set! all-data
|
gnc:optname-reportname
|
||||||
(append start
|
(if show-fullname?
|
||||||
(list (list (G_ "Other") other-sum))))
|
(gnc-account-get-full-name acct)
|
||||||
(let* ((options (gnc:make-report-options reportguid)))
|
(xaccAccountGetName acct)))))))))
|
||||||
;; now copy all the options
|
(gnc:html-chart-add-data-series!
|
||||||
(gnc:options-copy-values
|
chart label amounts color
|
||||||
(gnc:report-options report-obj) options)
|
'stack stack 'fill fill 'urls urls)))
|
||||||
;; and set the destination accounts
|
all-data
|
||||||
(gnc:option-set-value
|
(gnc:assign-colors (length all-data))
|
||||||
(gnc:lookup-option options gnc:pagename-accounts
|
(iota (length all-data)))
|
||||||
optname-accounts)
|
|
||||||
(map car finish))
|
|
||||||
;; Set the URL to point to this report.
|
|
||||||
(set! other-anchor
|
|
||||||
(gnc:report-anchor-text
|
|
||||||
(gnc:make-report reportguid options))))))
|
|
||||||
|
|
||||||
(gnc:report-percent-done 92)
|
(gnc:html-chart-set-stacking?! chart stacked?)
|
||||||
|
(gnc:html-chart-set-currency-iso!
|
||||||
|
chart (gnc-commodity-get-mnemonic report-currency))
|
||||||
|
(gnc:html-chart-set-currency-symbol!
|
||||||
|
chart (gnc-commodity-get-nice-symbol report-currency))
|
||||||
|
|
||||||
(for-each
|
(gnc:report-percent-done 98)
|
||||||
(lambda (series color stack)
|
(gnc:html-document-add-object! document chart)
|
||||||
(let* ((acct (car series))
|
|
||||||
(label (cond
|
|
||||||
((string? acct)
|
|
||||||
(car series))
|
|
||||||
(show-fullname?
|
|
||||||
(gnc-account-get-full-name acct))
|
|
||||||
(else (xaccAccountGetName acct))))
|
|
||||||
(amounts (map gnc:gnc-monetary-amount (cadr series)))
|
|
||||||
(stack (if stacked?
|
|
||||||
"default"
|
|
||||||
(number->string stack)))
|
|
||||||
(fill (eq? chart-type 'barchart))
|
|
||||||
(urls (cond
|
|
||||||
((string? acct)
|
|
||||||
other-anchor)
|
|
||||||
|
|
||||||
((null? (gnc-account-get-children acct))
|
(when show-table?
|
||||||
(gnc:account-anchor-text acct))
|
(let ((table (gnc:make-html-table))
|
||||||
|
(scu (gnc-commodity-get-fraction report-currency))
|
||||||
|
(cols>1? (pair? (cdr all-data))))
|
||||||
|
|
||||||
;; because the tree-depth option for
|
(define (make-cell contents)
|
||||||
;; accounts/levels goes up to 6. FIXME:
|
(gnc:make-html-table-cell/markup "number-cell" contents))
|
||||||
;; magic number.
|
|
||||||
((>= tree-depth 6)
|
|
||||||
(gnc:account-anchor-text acct))
|
|
||||||
|
|
||||||
(else
|
(for-each
|
||||||
(gnc:make-report-anchor
|
(lambda (date row)
|
||||||
reportguid report-obj
|
(gnc:html-table-append-row!
|
||||||
|
table
|
||||||
|
(append (list (make-cell date))
|
||||||
|
(map make-cell row)
|
||||||
|
(if cols>1?
|
||||||
(list
|
(list
|
||||||
(list gnc:pagename-accounts optname-accounts
|
(make-cell (apply gnc:monetary+ row)))
|
||||||
(cons acct (gnc-account-get-children acct)))
|
'()))))
|
||||||
(list gnc:pagename-accounts optname-levels
|
date-string-list
|
||||||
(1+ tree-depth))
|
(apply zip (map cadr all-data)))
|
||||||
(list gnc:pagename-general
|
|
||||||
gnc:optname-reportname
|
|
||||||
(if show-fullname?
|
|
||||||
(gnc-account-get-full-name acct)
|
|
||||||
(xaccAccountGetName acct)))))))))
|
|
||||||
(gnc:html-chart-add-data-series!
|
|
||||||
chart label amounts color
|
|
||||||
'stack stack 'fill fill 'urls urls)))
|
|
||||||
all-data
|
|
||||||
(gnc:assign-colors (length all-data))
|
|
||||||
(iota (length all-data)))
|
|
||||||
|
|
||||||
(gnc:html-chart-set-stacking?! chart stacked?)
|
(gnc:html-table-set-col-headers!
|
||||||
(gnc:html-chart-set-currency-iso!
|
table
|
||||||
chart (gnc-commodity-get-mnemonic report-currency))
|
(append
|
||||||
(gnc:html-chart-set-currency-symbol!
|
(list (G_ "Date"))
|
||||||
chart (gnc-commodity-get-nice-symbol report-currency))
|
(map
|
||||||
|
(lambda (col)
|
||||||
|
(cond
|
||||||
|
((string? col) col)
|
||||||
|
(show-fullname? (gnc-account-get-full-name col))
|
||||||
|
(else (xaccAccountGetName col))))
|
||||||
|
(map car all-data))
|
||||||
|
(if cols>1?
|
||||||
|
(list (G_ "Grand Total"))
|
||||||
|
'())))
|
||||||
|
|
||||||
(gnc:report-percent-done 98)
|
(gnc:html-document-add-object! document table)))
|
||||||
(gnc:html-document-add-object! document chart)
|
|
||||||
|
|
||||||
(when show-table?
|
(cond
|
||||||
(let ((table (gnc:make-html-table))
|
((eq? export-type 'csv)
|
||||||
(scu (gnc-commodity-get-fraction report-currency))
|
(let ((iso-date (qof-date-format-get-string QOF-DATE-FORMAT-ISO)))
|
||||||
(cols>1? (pair? (cdr all-data))))
|
(gnc:html-document-set-export-string
|
||||||
|
document
|
||||||
(define (make-cell contents)
|
(gnc:lists->csv
|
||||||
(gnc:make-html-table-cell/markup "number-cell" contents))
|
(cons (append
|
||||||
|
(list (G_ "Date"))
|
||||||
(for-each
|
|
||||||
(lambda (date row)
|
|
||||||
(gnc:html-table-append-row!
|
|
||||||
table
|
|
||||||
(append (list (make-cell date))
|
|
||||||
(map make-cell row)
|
|
||||||
(if cols>1?
|
|
||||||
(list
|
|
||||||
(make-cell (apply gnc:monetary+ row)))
|
|
||||||
'()))))
|
|
||||||
date-string-list
|
|
||||||
(apply zip (map cadr all-data)))
|
|
||||||
|
|
||||||
(gnc:html-table-set-col-headers!
|
|
||||||
table
|
|
||||||
(append
|
|
||||||
(list (G_ "Date"))
|
|
||||||
(map
|
|
||||||
(lambda (col)
|
|
||||||
(cond
|
|
||||||
((string? col) col)
|
|
||||||
(show-fullname? (gnc-account-get-full-name col))
|
|
||||||
(else (xaccAccountGetName col))))
|
|
||||||
(map car all-data))
|
|
||||||
(if cols>1?
|
|
||||||
(list (G_ "Grand Total"))
|
|
||||||
'())))
|
|
||||||
|
|
||||||
(gnc:html-document-add-object! document table)))
|
|
||||||
|
|
||||||
(cond
|
|
||||||
((eq? export-type 'csv)
|
|
||||||
(let ((iso-date (qof-date-format-get-string QOF-DATE-FORMAT-ISO)))
|
|
||||||
(gnc:html-document-set-export-string
|
|
||||||
document
|
|
||||||
(gnc:lists->csv
|
|
||||||
(cons (append
|
|
||||||
(list (G_ "Date"))
|
|
||||||
(map
|
|
||||||
(lambda (col)
|
|
||||||
(cond
|
|
||||||
((string? col) col)
|
|
||||||
(show-fullname? (gnc-account-get-full-name col))
|
|
||||||
(else (xaccAccountGetName col))))
|
|
||||||
(map car all-data))
|
|
||||||
(if (pair? (cdr all-data))
|
|
||||||
(list (G_ "Grand Total"))
|
|
||||||
'()))
|
|
||||||
(map
|
(map
|
||||||
(lambda (date row)
|
(lambda (col)
|
||||||
(append
|
(cond
|
||||||
(list date)
|
((string? col) col)
|
||||||
row
|
(show-fullname? (gnc-account-get-full-name col))
|
||||||
(if (pair? (cdr all-data))
|
(else (xaccAccountGetName col))))
|
||||||
(list (apply gnc:monetary+ row))
|
(map car all-data))
|
||||||
'())))
|
(if (pair? (cdr all-data))
|
||||||
(map (cut gnc-print-time64 <> iso-date) dates-list)
|
(list (G_ "Grand Total"))
|
||||||
(apply zip (map cadr all-data))))))))))
|
'()))
|
||||||
|
(map
|
||||||
;; else if empty data
|
(lambda (date row)
|
||||||
(gnc:html-document-add-object!
|
(append
|
||||||
document
|
(list date)
|
||||||
(gnc:html-make-empty-data-warning
|
row
|
||||||
report-title (gnc:report-id report-obj)))))
|
(if (pair? (cdr all-data))
|
||||||
|
(list (apply gnc:monetary+ row))
|
||||||
;; else if no accounts selected
|
'())))
|
||||||
(gnc:html-document-add-object!
|
(map (cut gnc-print-time64 <> iso-date) dates-list)
|
||||||
document
|
(apply zip (map cadr all-data)))))))))))))))
|
||||||
(gnc:html-make-no-account-warning
|
|
||||||
report-title (gnc:report-id report-obj))))
|
|
||||||
|
|
||||||
(unless (gnc:html-document-export-string document)
|
(unless (gnc:html-document-export-string document)
|
||||||
(gnc:html-document-set-export-error document (G_ "No exportable data")))
|
(gnc:html-document-set-export-error document (G_ "No exportable data")))
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user