1;; -*-scheme-*-
2;; customer-summary.scm -- Print a summary of profit per customer
3;;
4;; Created by:  Christian Stimming
5;; Copyright (c) 2010 Christian Stimming <christian@cstimming.de>
6;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
7;;
8;; This program is free software; you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation; either version 2 of
11;; the License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16;; GNU General Public License for more details.
17;;
18;; You should have received a copy of the GNU General Public License
19;; along with this program; if not, contact:
20;;
21;; Free Software Foundation           Voice:  +1-617-542-5942
22;; 51 Franklin Street, Fifth Floor    Fax:    +1-617-542-2652
23;; Boston, MA  02110-1301,  USA       gnu@gnu.org
24
25;; This report is based on the code in owner-report.scm, but it does
26;; not only print a summary for one single owner (here: only
27;; customers), but instead a table showing all customers.
28
29(define-module (gnucash reports standard customer-summary))
30
31(use-modules (srfi srfi-1))
32(use-modules (gnucash engine))
33(use-modules (gnucash utilities))                ; for gnc:debug
34(use-modules (gnucash core-utils))
35(use-modules (gnucash app-utils))
36(use-modules (gnucash report))
37(use-modules (gnucash reports))
38
39;; Option names
40(define optname-from-date (N_ "From"))
41(define optname-to-date (N_ "To"))
42
43;; let's define a name for the report-guid's, much prettier
44(define customer-report-guid "4166a20981985fd2b07ff8cb3b7d384e")
45
46;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47
48(define pagename-incomeaccounts (N_ "Income Accounts"))
49(define optname-incomeaccounts (N_ "Income Accounts"))
50(define opthelp-incomeaccounts
51  (N_ "The income accounts where the sales and income was recorded."))
52
53;; The line break in the next expressions will suppress above comment as translator comments.
54
55(define pagename-expenseaccounts
56  (N_ "Expense Accounts"))
57(define optname-expenseaccounts (N_ "Expense Accounts"))
58
59;; The line break in the next expressions will suppress above comment as translator comments.
60(define opthelp-expenseaccounts
61  (N_ "The expense accounts where the expenses are recorded which are subtracted from the sales to give the profit."))
62
63(define optname-show-column-expense (N_ "Show Expense Column"))
64(define opthelp-show-column-expense (N_ "Show the column with the expenses per customer."))
65(define optname-show-own-address (N_ "Show Company Address"))
66(define opthelp-show-own-address (N_ "Show your own company's address and the date of printing."))
67
68;; The line break in the next expression will suppress above comments as translator comments.
69
70(define optname-show-zero-lines (N_ "Show Lines with All Zeros"))
71(define opthelp-show-zero-lines (N_ "Show the table lines with customers which did not have any transactions in the reporting period, hence would show all zeros in the columns."))
72(define optname-show-inactive (N_ "Show Inactive Customers"))
73(define opthelp-show-inactive (N_ "Include customers that have been marked inactive."))
74
75(define optname-sortkey (N_ "Sort Column"))
76(define opthelp-sortkey (N_ "Choose the column by which the result table is sorted."))
77(define optname-sortascending (N_ "Sort Order"))
78(define opthelp-sortascending (N_ "Choose the ordering of the column sort."))
79
80
81(define (options-generator)
82  (define options (gnc:new-options))
83
84  (define (add-option new-option)
85    (gnc:register-option options new-option))
86
87  (gnc:options-add-date-interval!
88   options gnc:pagename-general optname-from-date optname-to-date "b")
89
90  (add-option
91   (gnc:make-account-list-option
92    pagename-incomeaccounts optname-incomeaccounts
93    "b" opthelp-incomeaccounts
94    (lambda ()
95      (gnc:filter-accountlist-type
96       (list ACCT-TYPE-INCOME)
97       (gnc-account-get-descendants-sorted (gnc-get-current-root-account))))
98    #f #t))
99
100  (add-option
101   (gnc:make-account-list-option
102    pagename-expenseaccounts optname-expenseaccounts
103    "b" opthelp-expenseaccounts
104    (lambda ()
105      (gnc:filter-accountlist-type
106       (list ACCT-TYPE-EXPENSE)
107       (gnc-account-get-descendants-sorted (gnc-get-current-root-account))))
108    #f #t))
109
110  (add-option
111   (gnc:make-multichoice-option
112    gnc:pagename-display optname-sortkey
113    "a" opthelp-sortkey
114    'customername
115    (list
116     (vector 'customername (N_ "Customer Name"))
117     (vector 'profit (N_ "Profit"))
118     (vector 'markup (N_ "Markup (which is profit amount divided by sales)"))
119     (vector 'sales (N_ "Sales"))
120     (vector 'expense (N_ "Expense")))))
121
122  (add-option
123   (gnc:make-multichoice-option
124    gnc:pagename-display optname-sortascending
125    "b" opthelp-sortascending
126    'ascend
127    (list
128     (vector 'ascend (N_ "Ascending"))
129     (vector 'descend (N_ "Descending")))))
130
131  (add-option
132   (gnc:make-simple-boolean-option
133    gnc:pagename-display optname-show-own-address
134    "d" opthelp-show-own-address #t))
135
136  (add-option
137   (gnc:make-simple-boolean-option
138    gnc:pagename-display optname-show-zero-lines
139    "e" opthelp-show-zero-lines #f))
140
141  (add-option
142   (gnc:make-simple-boolean-option
143    gnc:pagename-display optname-show-inactive
144    "f" opthelp-show-inactive #f))
145
146  (add-option
147   (gnc:make-simple-boolean-option
148    gnc:pagename-display optname-show-column-expense
149    "g" opthelp-show-column-expense #t))
150
151  (gnc:options-set-default-section options gnc:pagename-general)
152
153  options)
154
155;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156
157(define (query owner account-list start-date end-date)
158  (let* ((q (qof-query-create-for-splits))
159         (guid (and owner
160                    (gncOwnerReturnGUID (gncOwnerGetEndOwner owner)))))
161    (when owner
162      (qof-query-add-guid-match
163       q (list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-OWNER OWNER-PARENTG)
164       guid QOF-QUERY-OR)
165      (qof-query-add-guid-match
166       q (list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-BILLTO OWNER-PARENTG)
167       guid QOF-QUERY-OR))
168    ;; Apparently those query terms are unneeded because we never take
169    ;; lots into account?!?
170    ;; (qof-query-add-guid-match
171    ;;  q (list SPLIT-LOT OWNER-FROM-LOT OWNER-PARENTG)
172    ;;  guid QOF-QUERY-OR)
173    ;; (qof-query-add-guid-match
174    ;;  q (list SPLIT-LOT INVOICE-FROM-LOT INVOICE-OWNER OWNER-PARENTG)
175    ;;  guid QOF-QUERY-OR)
176    ;; (qof-query-add-guid-match
177    ;;  q (list SPLIT-LOT INVOICE-FROM-LOT INVOICE-BILLTO OWNER-PARENTG)
178    ;;  guid QOF-QUERY-OR)
179    (xaccQueryAddAccountMatch q account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
180    (xaccQueryAddDateMatchTT q #t start-date #t end-date QOF-QUERY-AND)
181    (xaccQueryAddClosingTransMatch q #f QOF-QUERY-AND)
182    (qof-query-set-book q (gnc-get-current-book))
183    (let ((result (qof-query-run q)))
184      (qof-query-destroy q)
185      result)))
186
187(define (make-myname-table book date-format)
188  (let* ((table (gnc:make-html-table))
189         (name (gnc:company-info book gnc:*company-name*))
190         (addy (gnc:company-info book gnc:*company-addy*)))
191    (gnc:html-table-set-style!
192     table "table"
193     'attribute (list "border" 0)
194     'attribute (list "width" "") ;; this way we force the override of the "100%" below
195     'attribute (list "align" "right")
196     'attribute (list "valign" "top")
197     'attribute (list "cellspacing" 0)
198     'attribute (list "cellpadding" 0))
199    (if name (gnc:html-table-append-row! table (list name)))
200    (if addy (gnc:html-table-append-row! table (gnc:multiline-to-html-text addy)))
201    (gnc:html-table-append-row!
202     table (list (gnc-print-time64 (gnc:get-today) date-format)))
203    (let ((table-outer (gnc:make-html-table)))
204      (gnc:html-table-set-style!
205       table-outer "table"
206       'attribute (list "border" 0)
207       'attribute (list "width" "100%")
208       'attribute (list "valign" "top")
209       'attribute (list "cellspacing" 0)
210       'attribute (list "cellpadding" 0))
211      (gnc:html-table-append-row! table-outer (list table))
212      table-outer)))
213
214(define (markup-percent profit sales)
215  (if (zero? sales) 0
216      (* 100 (/ profit sales))))
217
218(define (filter-splits splits accounts)
219  (apply gnc:monetaries-add
220         (map (lambda (s)
221                (gnc:make-gnc-monetary
222                 (xaccTransGetCurrency (xaccSplitGetParent s))
223                 (xaccSplitGetValue s)))
224              (filter
225               (lambda (s)
226                 (member (xaccSplitGetAccount s) accounts))
227               splits))))
228
229
230;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
231
232(define (reg-renderer report-obj)
233  (define (opt-val section name)
234    (gnc:option-value
235     (gnc:lookup-option (gnc:report-options report-obj) section name)))
236
237  (let* ((document (gnc:make-html-document))
238         (report-title (opt-val gnc:pagename-general gnc:optname-reportname))
239         (start-date (gnc:time64-start-day-time
240                      (gnc:date-option-absolute-time
241                       (opt-val gnc:pagename-general optname-from-date))))
242         (end-date (gnc:time64-end-day-time
243                    (gnc:date-option-absolute-time
244                     (opt-val gnc:pagename-general optname-to-date))))
245         (sort-order (opt-val gnc:pagename-display optname-sortascending))
246         (sort-key (opt-val gnc:pagename-display optname-sortkey))
247         (show-zero-lines? (opt-val gnc:pagename-display optname-show-zero-lines))
248         (show-column-expense?
249          (opt-val gnc:pagename-display optname-show-column-expense))
250         (show-own-address? (opt-val gnc:pagename-display optname-show-own-address))
251         (expense-accounts (opt-val pagename-expenseaccounts optname-expenseaccounts))
252         (sales-accounts (opt-val pagename-incomeaccounts optname-incomeaccounts))
253         (all-accounts (append sales-accounts expense-accounts))
254         (commodities (gnc:accounts-get-commodities all-accounts #f))
255         (commodities>1? (> (length commodities) 1))
256         (book (gnc-get-current-book))
257         (date-format (gnc:options-fancy-date book))
258         (ownerlist (gncBusinessGetOwnerList
259                     book
260                     (gncOwnerTypeToQofIdType GNC-OWNER-CUSTOMER)
261                     (opt-val gnc:pagename-display optname-show-inactive)))
262         (toplevel-total-sales (gnc:make-commodity-collector))
263         (toplevel-total-expense (gnc:make-commodity-collector))
264         (type-str (N_ "Customer")))
265
266    (gnc:html-document-set-title!
267     document (string-append (G_ type-str) " " (G_ "Report")))
268
269    (gnc:html-document-set-title!
270     document (format #f (G_ "~a ~a - ~a")
271                      report-title
272                      (qof-print-date start-date)
273                      (qof-print-date end-date)))
274
275    (when show-own-address?
276      (gnc:html-document-add-object!
277       document (make-myname-table book date-format)))
278
279    (cond
280     ((null? sales-accounts)
281      (gnc:html-document-add-object!
282       document
283       (gnc:html-make-no-account-warning
284        report-title (gnc:report-id report-obj))))
285
286     ((null? ownerlist)
287      (gnc:html-document-add-object!
288       document
289       (gnc:make-html-text
290        (G_ "No valid customer found."))))
291
292     (else
293      (let ((all-splits (query #f all-accounts start-date end-date))
294            (table (gnc:make-html-table))
295            (total-sales (gnc:make-commodity-collector))
296            (total-expense (gnc:make-commodity-collector))
297            (headings (cons* (G_ "Customer")
298                             (G_ "Profit")
299                             (G_ "Markup")
300                             (G_ "Sales")
301                             (if show-column-expense?
302                                 (list (G_ "Expense"))
303                                 '())))
304            (results (map
305                      (lambda (owner)
306                        (let* ((splits (query owner all-accounts start-date end-date))
307                               (sales (gnc:commodity-collector-get-negated
308                                       (filter-splits splits sales-accounts)))
309                               (expense (filter-splits splits expense-accounts))
310                               (profit (gnc:collector- sales expense)))
311                          (list owner profit sales expense)))
312                      ownerlist))
313            (sortingtable '()))
314
315        (define (add-row str curr markup profit sales expense url)
316          (gnc:html-table-append-row!
317           table (cons* (if url
318                            (gnc:make-html-text (gnc:html-markup-anchor url str))
319                            str)
320                        (map
321                         (lambda (cell)
322                           (gnc:make-html-table-cell/markup "number-cell" cell))
323                         (cons* profit
324                                (and markup (format #f "~a%" (round markup)))
325                                sales
326                                (if show-column-expense?
327                                    (list expense)
328                                    '()))))))
329
330        (let ((sales (gnc:commodity-collector-get-negated
331                      (filter-splits all-splits sales-accounts)))
332              (expense (filter-splits all-splits expense-accounts)))
333          (toplevel-total-sales 'merge sales #f)
334          (toplevel-total-expense 'merge expense #f))
335
336        ;; The actual content - add onto sortingtable
337        (for-each
338         (lambda (row)
339           (let* ((owner (car row))
340                  (profit (cadr row))
341                  (sales (caddr row))
342                  (expense (cadddr row)))
343             (total-sales 'merge sales #f)
344             (total-expense 'merge expense #f)
345             (for-each
346              (lambda (comm)
347                (let* ((comm-profit (cadr (profit 'getpair comm #f)))
348                       (comm-sales (cadr (sales 'getpair comm #f)))
349                       (comm-expense (cadr (expense 'getpair comm #f)))
350                       (markup (markup-percent comm-profit comm-sales)))
351                  (when (or show-zero-lines?
352                            (not (and (zero? comm-profit) (zero? comm-sales))))
353                    (set! sortingtable
354                      (cons (vector
355                             (gncOwnerGetName owner) comm markup
356                             comm-profit comm-sales comm-expense
357                             (gnc:report-anchor-text
358                              (gnc:owner-report-create-with-enddate owner '() #f)))
359                            sortingtable)))))
360              commodities)))
361         results)
362
363        ;; Add the "No Customer" lines to the sortingtable for sorting
364        ;; as well
365        (let* ((other-sales (gnc:collector- toplevel-total-sales total-sales))
366               (other-expense (gnc:collector- toplevel-total-expense
367                                                  total-expense))
368               (other-profit (gnc:collector- other-sales other-expense)))
369          (for-each
370           (lambda (comm)
371             (let* ((profit (cadr (other-profit 'getpair comm #f)))
372                    (sales (cadr (other-sales 'getpair comm #f)))
373                    (expense (cadr (other-expense 'getpair comm #f)))
374                    (markup (markup-percent profit sales)))
375               (unless (and (zero? profit) (zero? sales))
376                 (set! sortingtable
377                   (cons (vector
378                          (G_ "No Customer") comm markup profit sales expense #f)
379                         sortingtable)))))
380           commodities))
381
382        ;; Stable-sort the sortingtable according to column, then
383        ;; stable-sort according to currency. This results in group-by
384        ;; currency then sort by columns.
385        (let* ((str-op (if (eq? sort-order 'descend)
386                           gnc:string-locale>?
387                           gnc:string-locale<?))
388               (op (if (eq? sort-order 'descend) > <)))
389          (define (<? key)
390            (case key
391              ;; customername sorting is handled differently; this
392              ;; conditional ensures "No Customer" entries,
393              ;; i.e. without owner-report url, are printed last.
394              ((customername)
395               (lambda (a b)
396                 (cond
397                  ((not (vector-ref b 6)) #t)
398                  ((not (vector-ref a 6)) #f)
399                  (else (str-op (vector-ref a 0) (vector-ref b 0))))))
400              ;; currency sorting always alphabetical a-z
401              ((currency)
402               (lambda (a b) (gnc:string-locale<?
403                              (gnc-commodity-get-mnemonic (vector-ref a 1))
404                              (gnc-commodity-get-mnemonic (vector-ref b 1)))))
405              ((markup)
406               (lambda (a b) (op (vector-ref a 2) (vector-ref b 2))))
407              ((profit)
408               (lambda (a b) (op (vector-ref a 3) (vector-ref b 3))))
409              ((sales)
410               (lambda (a b) (op (vector-ref a 4) (vector-ref b 4))))
411              ((expense)
412               (lambda (a b) (op (vector-ref a 5) (vector-ref b 5))))))
413          (set! sortingtable (stable-sort! sortingtable (<? sort-key)))
414          (when (memq sort-key '(profit sales expense))
415            (set! sortingtable (stable-sort! sortingtable (<? 'currency)))))
416
417        ;; After sorting, add the entries to the resultant table
418        (let lp ((sortingtable sortingtable)
419                 (last-comm #f))
420          (unless (null? sortingtable)
421            (let* ((elt (car sortingtable))
422                   (comm (vector-ref elt 1)))
423              (when (and commodities>1?
424                         (memq sort-key '(profit sales expense))
425                         (not (and last-comm (gnc-commodity-equiv last-comm comm))))
426                (add-row (gnc-commodity-get-mnemonic comm) #f #f #f #f #f #f))
427              (add-row (vector-ref elt 0)
428                       comm
429                       (vector-ref elt 2)
430                       (gnc:make-gnc-monetary comm (vector-ref elt 3))
431                       (gnc:make-gnc-monetary comm (vector-ref elt 4))
432                       (gnc:make-gnc-monetary comm (vector-ref elt 5))
433                       (vector-ref elt 6))
434              (lp (cdr sortingtable) comm))))
435
436        ;; One horizontal ruler before the summary
437        (gnc:html-table-append-row!
438         table (list
439                (gnc:make-html-table-cell/size
440                 1 (length headings)
441                 (gnc:make-html-text (gnc:html-markup/attr/no-end "hr" "noshade")))))
442
443        ;; Summary lines - 1 per currency
444        (let ((total-profit (gnc:collector- toplevel-total-sales
445                                            toplevel-total-expense)))
446          (for-each
447           (lambda (comm)
448             (let* ((profit (cadr (total-profit 'getpair comm #f)))
449                    (sales (cadr (toplevel-total-sales 'getpair comm #f)))
450                    (expense (cadr (toplevel-total-expense 'getpair comm #f)))
451                    (markup (markup-percent profit sales)))
452               (add-row (if commodities>1?
453                            (format #f "~a (~a)"
454                                    (G_ "Total")
455                                    (gnc-commodity-get-mnemonic comm))
456                            (G_ "Total"))
457                        comm markup
458                        (gnc:make-gnc-monetary comm profit)
459                        (gnc:make-gnc-monetary comm sales)
460                        (gnc:make-gnc-monetary comm expense)
461                        #f)))
462           commodities))
463
464        ;; Heading line
465        (gnc:html-table-set-col-headers! table headings)
466
467        ;; Set the formatting styles
468        (gnc:html-table-set-style!
469         table "td"
470         'attribute '("align" "right")
471         'attribute '("valign" "top"))
472
473        (gnc:html-table-set-col-style!
474         table 0 "td"
475         'attribute '("align" "left"))
476
477        (gnc:html-table-set-style!
478         table "table"
479         ;;'attribute (list "border" 1)
480         'attribute (list "cellspacing" 2)
481         'attribute (list "cellpadding" 4))
482
483        ;; And add the table to the document
484        (gnc:html-document-add-object! document table))))
485
486    document))
487
488;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
489
490(gnc:define-report
491 'version 1
492 'name (N_ "Customer Summary")
493 'report-guid customer-report-guid
494 'menu-path (list gnc:menuname-business-reports)
495 'options-generator options-generator
496 'renderer reg-renderer
497 'in-menu? #t)
498
499