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