1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2
;; category-barchart.scm: shows barchart of income/expense categories
4
;; By Christian Stimming <stimming@tu-harburg.de>
6
;; This program is free software; you can redistribute it and/or
7
;; modify it under the terms of the GNU General Public License as
8
;; published by the Free Software Foundation; either version 2 of
9
;; the License, or (at your option) any later version.
11
;; This program is distributed in the hope that it will be useful,
12
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14
;; GNU General Public License for more details.
16
;; You should have received a copy of the GNU General Public License
17
;; along with this program; if not, contact:
19
;; Free Software Foundation Voice: +1-617-542-5942
20
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
21
;; Boston, MA 02111-1307, USA gnu@gnu.org
23
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25
;; depends must be outside module scope -- and should eventually go away.
26
(gnc:depend "report-html.scm")
27
(gnc:depend "date-utilities.scm")
29
(define-module (gnucash report category-barchart))
30
(use-modules (srfi srfi-1))
31
(use-modules (ice-9 slib))
34
;; The option names are defined here to 1. save typing and 2. avoid
35
;; spelling errors. The *reportnames* are defined here (and not only
36
;; once at the very end) because I need them to define the "other"
37
;; report, thus needing them twice.
38
(define menuname-income (N_ "Income Barchart"))
39
(define menuname-expense (N_ "Expense Barchart"))
40
(define menuname-assets (N_ "Asset Barchart"))
41
(define menuname-liabilities (N_ "Liability Barchart"))
42
;; The names are used in the menu
44
;; The menu statusbar tips.
45
(define menutip-income
46
(N_ "Shows a barchart with the Income per interval \
47
developing over time"))
48
(define menutip-expense
49
(N_ "Shows a barchart with the Expenses per interval \
50
developing over time"))
51
(define menutip-assets
52
(N_ "Shows a barchart with the Assets developing over time"))
53
(define menutip-liabilities
54
(N_ "Shows a barchart with the Liabilities \
55
developing over time"))
57
;; The names here are used 1. for internal identification, 2. as
58
;; tab labels, 3. as default for the 'Report name' option which
59
;; in turn is used for the printed report title.
60
(define reportname-income (N_ "Income Over Time"))
61
(define reportname-expense (N_ "Expense Over Time"))
62
(define reportname-assets (N_ "Assets Over Time"))
63
(define reportname-liabilities (N_ "Liabilities Over Time"))
66
(define optname-from-date (N_ "From"))
67
(define optname-to-date (N_ "To"))
68
(define optname-stepsize (N_ "Step Size"))
69
(define optname-report-currency (N_ "Report's currency"))
70
(define optname-price-source (N_ "Price Source"))
72
(define optname-accounts (N_ "Accounts"))
73
(define optname-levels (N_ "Show Accounts until level"))
75
(define optname-fullname (N_ "Show long account names"))
76
(define optname-stacked (N_ "Use Stacked Bars"))
77
(define optname-slices (N_ "Maximum Bars"))
78
(define optname-plot-width (N_ "Plot Width"))
79
(define optname-plot-height (N_ "Plot Height"))
81
(define (options-generator account-types)
82
(let* ((options (gnc:new-options))
85
(gnc:register-option options new-option))))
88
(gnc:options-add-date-interval!
89
options gnc:pagename-general
90
optname-from-date optname-to-date "a")
92
(gnc:options-add-interval-choice!
93
options gnc:pagename-general optname-stepsize "b" 'MonthDelta)
95
(gnc:options-add-currency!
96
options gnc:pagename-general optname-report-currency "c")
98
(gnc:options-add-price-source!
99
options gnc:pagename-general
100
optname-price-source "d" 'weighted-average)
104
(gnc:make-account-list-option
105
gnc:pagename-accounts optname-accounts
107
(N_ "Report on these accounts, if chosen account level allows.")
109
(gnc:filter-accountlist-type
111
(gnc:group-get-subaccounts (gnc:get-current-group))))
114
(gnc:filter-accountlist-type account-types accounts)))
117
(gnc:options-add-account-levels!
118
options gnc:pagename-accounts optname-levels "c"
119
(N_ "Show accounts to this depth and not further")
124
(gnc:make-simple-boolean-option
125
gnc:pagename-display optname-fullname
126
"a" (N_ "Show the full account name in legend?") #f))
129
(gnc:make-simple-boolean-option
130
gnc:pagename-display optname-stacked
132
(N_ "Show barchart as stacked barchart? (Guppi>=0.35.4 required)")
136
(gnc:make-number-range-option
137
gnc:pagename-display optname-slices
138
"c" (N_ "Maximum number of bars in the chart") 8
141
(gnc:options-add-plot-size!
142
options gnc:pagename-display
143
optname-plot-width optname-plot-height "c" 400 400)
145
(gnc:options-set-default-section options gnc:pagename-general)
149
;; This is the rendering function. It accepts a database of options
150
;; and generates an object of type <html-document>. See the file
151
;; report-html.txt for documentation; the file report-html.scm
152
;; includes all the relevant Scheme code. The option database passed
153
;; to the function is one created by the options-generator function
156
;; FIXME: the exchange rate should change every time interval, of
157
;; course, but right now we assume the very last exchange rate to be
158
;; constant over the whole report period. Note that this might get
159
;; *really* complicated.
161
(define (category-barchart-renderer report-obj reportname
162
account-types do-intervals?)
163
;; A helper functions for looking up option values.
164
(define (get-option section name)
167
(gnc:report-options report-obj) section name)))
169
(let ((to-date-tp (gnc:timepair-end-day-time
170
(gnc:date-option-absolute-time
171
(get-option gnc:pagename-general
173
(from-date-tp (gnc:timepair-start-day-time
174
(gnc:date-option-absolute-time
175
(get-option gnc:pagename-general
176
optname-from-date))))
177
(interval (get-option gnc:pagename-general optname-stepsize))
178
(report-currency (get-option gnc:pagename-general
179
optname-report-currency))
180
(price-source (get-option gnc:pagename-general
181
optname-price-source))
182
(report-title (get-option gnc:pagename-general
183
gnc:optname-reportname))
185
(accounts (get-option gnc:pagename-accounts optname-accounts))
186
(account-levels (get-option gnc:pagename-accounts optname-levels))
188
(stacked? (get-option gnc:pagename-display optname-stacked))
189
(show-fullname? (get-option gnc:pagename-display optname-fullname))
190
(max-slices (get-option gnc:pagename-display optname-slices))
191
(height (get-option gnc:pagename-display optname-plot-height))
192
(width (get-option gnc:pagename-display optname-plot-width))
194
(document (gnc:make-html-document))
195
(chart (gnc:make-html-barchart))
196
(topl-accounts (gnc:filter-accountlist-type
198
(gnc:group-get-account-list
199
(gnc:get-current-group)))))
201
;; Returns true if the account a was selected in the account
203
(define (show-acct? a)
207
(if (not (null? accounts))
209
;; Define more helper variables.
211
(let* ((commodity-list (gnc:accounts-get-commodities
213
(gnc:acccounts-get-all-subaccounts accounts)
216
(exchange-fn (gnc:case-exchange-time-fn
217
price-source report-currency
218
commodity-list to-date-tp))
219
(tree-depth (if (equal? account-levels 'all)
220
(gnc:get-current-group-depth)
222
;; This is the list of date intervals to calculate.
223
(dates-list (if do-intervals?
224
(gnc:make-date-interval-list
225
(gnc:timepair-start-day-time from-date-tp)
226
(gnc:timepair-end-day-time to-date-tp)
229
(gnc:timepair-end-day-time from-date-tp)
230
(gnc:timepair-end-day-time to-date-tp)
232
;; Here the date strings for the x-axis labels are
235
(map (lambda (date-list-item)
236
(gnc:timepair-to-datestring
244
;; Converts a commodity-collector into one single double
245
;; number, depending on the report currency and the
246
;; exchange-fn calculated above. Returns a double.
247
(define (collector->double c date)
248
;; Future improvement: Let the user choose which kind of
249
;; currency combining she want to be done.
250
(gnc:numeric-to-double
251
(gnc:gnc-monetary-amount
252
(gnc:sum-collector-commodity
254
(lambda (a b) (exchange-fn a b date))))))
256
;; Calculates the net balance (profit or loss) of an account in
257
;; the given time interval. date-list-entry is a pair containing
258
;; the start- and end-date of that interval. If subacct?==#t,
259
;; the subaccount's balances are included as well. Returns a
260
;; double, exchanged into the report-currency by the above
261
;; conversion function, and possibly with reversed sign.
262
(define (get-balance account date-list-entry subacct?)
263
((if (gnc:account-reverse-balance? account)
267
(gnc:account-get-comm-balance-interval
269
(first date-list-entry)
270
(second date-list-entry) subacct?)
271
(second date-list-entry))
273
(gnc:account-get-comm-balance-at-date
274
account date-list-entry subacct?)
277
;; Creates the <balance-list> to be used in the function
279
(define (account->balance-list account subacct?)
281
(lambda (d) (get-balance account d subacct?))
284
;; Calculates all account's balances. Returns a list of pairs:
285
;; (<account> <balance-list>), like '((Earnings (10.0 11.2))
286
;; (Gifts (12.3 14.5))), where each element of <balance-list>
287
;; is the balance corresponding to one element in
290
;; If current-depth >= tree-depth, then the balances are
291
;; calculated *with* subaccount's balances. Else only the
292
;; current account is regarded. Note: All accounts in accts
293
;; and all their subaccounts are processed, but a balances is
294
;; calculated and returned *only* for those accounts where
295
;; show-acct? is true. This is necessary because otherwise we
296
;; would forget an account that is selected but not its
298
(define (traverse-accounts current-depth accts)
299
(if (< current-depth tree-depth)
306
(cons (list a (account->balance-list a #f))
311
(gnc:account-get-immediate-subaccounts a))
315
;; else (i.e. current-depth == tree-depth)
318
(list a (account->balance-list a #t)))
319
(filter show-acct? accts))))
321
;; Sort the account list according to the account code field.
324
(not (= 0.0 (apply + (cadr l)))))
325
(traverse-accounts 1 topl-accounts))
327
(string<? (gnc:account-get-code (car a))
328
(gnc:account-get-code (car b))))))
329
;; Or rather sort by total amount?
330
;;(< (apply + (cadr a))
331
;; (apply + (cadr b))))))
332
;; Other sort criteria: max. amount, standard deviation of amount,
333
;; min. amount; ascending, descending. FIXME: Add user options to
337
;;(gnc:warn "all-data" all-data)
339
;; Proceed if the data is non-zeros
341
(and (not (null? all-data))
342
(gnc:not-all-zeros (map cadr all-data)))
344
;; Set chart title, subtitle etc.
345
(gnc:html-barchart-set-title! chart report-title)
346
(gnc:html-barchart-set-subtitle!
350
(_ "Balances %s to %s"))
351
(gnc:timepair-to-datestring from-date-tp)
352
(gnc:timepair-to-datestring to-date-tp)))
353
(gnc:html-barchart-set-width! chart width)
354
(gnc:html-barchart-set-height! chart height)
357
(gnc:html-barchart-set-row-labels! chart date-string-list)
358
;; FIXME: axis labels are not yet supported by
360
(gnc:html-barchart-set-y-axis-label!
361
chart (gnc:commodity-get-mnemonic report-currency))
362
(gnc:html-barchart-set-row-labels-rotated?! chart #t)
363
(gnc:html-barchart-set-stacked?! chart stacked?)
364
;; If this is a stacked barchart, then reverse the legend.
365
(gnc:html-barchart-set-legend-reversed?! chart stacked?)
367
;; If we have too many categories, we sum them into a new
368
;; 'other' category and add a link to a new report with just
370
(if (> (length all-data) max-slices)
371
(let* ((start (take all-data (- max-slices 1)))
372
(finish (drop all-data (- max-slices 1)))
374
(lambda (l) (apply + l))
375
(apply zip (map cadr finish)))))
378
(list (list (_ "Other") other-sum))))
379
(let* ((options (gnc:make-report-options reportname))
381
;; now copy all the options
382
(gnc:options-copy-values
383
(gnc:report-options report-obj) options)
384
;; and set the destination accounts
385
(gnc:option-set-value
386
(gnc:lookup-option options gnc:pagename-accounts
389
;; Set the URL to point to this report.
390
(set! id (gnc:make-report reportname options))
391
(set! other-anchor (gnc:report-anchor-text id)))))
394
;; This adds the data. Note the apply-zip stuff: This
395
;; transposes the data, i.e. swaps rows and columns. Pretty
396
;; cool, eh? Courtesy of dave_p.
397
(if (not (null? all-data))
398
(gnc:html-barchart-set-data!
400
(apply zip (map cadr all-data))))
403
(gnc:html-barchart-set-col-labels!
404
chart (map (lambda (pair)
405
(if (string? (car pair))
408
gnc:account-get-full-name
409
gnc:account-get-name) (car pair))))
411
(gnc:html-barchart-set-col-colors!
413
(gnc:assign-colors (length all-data)))
415
;; set the URLs; the slices are links to other reports
423
(let* ((acct (car pair))
425
(gnc:account-get-immediate-subaccounts acct)))
427
;; if leaf-account, make this an anchor
429
(gnc:account-anchor-text acct)
430
;; if non-leaf account, make this a link
431
;; to another report which is run on the
432
;; immediate subaccounts of this account
433
;; (and including this account).
434
(gnc:make-report-anchor
438
(list gnc:pagename-accounts optname-accounts
439
(cons acct subaccts))
440
(list gnc:pagename-accounts optname-levels
442
(list gnc:pagename-general
443
gnc:optname-reportname
445
gnc:account-get-full-name
446
gnc:account-get-name) acct))))))))
448
(gnc:html-barchart-set-button-1-bar-urls!
449
chart (append urls urls))
450
;; The legend urls do the same thing.
451
(gnc:html-barchart-set-button-1-legend-urls!
452
chart (append urls urls)))
454
(gnc:html-document-add-object! document chart))
456
;; else if empty data
457
(gnc:html-document-add-object!
459
(gnc:html-make-empty-data-warning
460
report-title (gnc:report-id report-obj)))))
462
;; else if no accounts selected
463
(gnc:html-document-add-object!
465
(gnc:html-make-no-account-warning
466
report-title (gnc:report-id report-obj))))
475
'menu-path (if (caddr l)
476
(list gnc:menuname-income-expense)
477
(list gnc:menuname-asset-liability))
478
'menu-name (cadddr l)
479
'menu-tip (car (cddddr l))
480
'options-generator (lambda () (options-generator (cadr l)))
481
'renderer (lambda (report-obj)
482
(category-barchart-renderer report-obj
487
;; reportname, account-types, do-intervals?,
488
;; menu-reportname, menu-tip
489
(list reportname-income '(income) #t menuname-income menutip-income)
490
(list reportname-expense '(expense) #t menuname-expense menutip-expense)
491
(list reportname-assets
492
'(asset bank cash checking savings money-market
493
stock mutual-fund currency)
494
#f menuname-assets menutip-assets)
495
(list reportname-liabilities
496
'(liability credit credit-line)
497
#f menuname-liabilities menutip-liabilities)))
added
removed
src/scm/report/category-barchart.scm
