mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Refactor payables report into a generic aging report (really just
the aging report framework) and then create a payables aging report and receivables aging report which use it. git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@6151 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Derek Atkins
parent
f224d041ad
commit
04eb2a6d6d
@ -21,6 +21,7 @@ gncscmmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report/
|
|||||||
gncscmmod_DATA = \
|
gncscmmod_DATA = \
|
||||||
account-piecharts.scm \
|
account-piecharts.scm \
|
||||||
account-summary.scm \
|
account-summary.scm \
|
||||||
|
aging.scm \
|
||||||
average-balance.scm \
|
average-balance.scm \
|
||||||
balance-sheet.scm \
|
balance-sheet.scm \
|
||||||
category-barchart.scm \
|
category-barchart.scm \
|
||||||
@ -29,6 +30,7 @@ gncscmmod_DATA = \
|
|||||||
pnl.scm \
|
pnl.scm \
|
||||||
portfolio.scm \
|
portfolio.scm \
|
||||||
price-scatter.scm \
|
price-scatter.scm \
|
||||||
|
receivables.scm \
|
||||||
register.scm \
|
register.scm \
|
||||||
standard-reports.scm \
|
standard-reports.scm \
|
||||||
transaction.scm
|
transaction.scm
|
||||||
|
|||||||
559
src/report/standard-reports/aging.scm
Normal file
559
src/report/standard-reports/aging.scm
Normal file
@ -0,0 +1,559 @@
|
|||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; aging.scm : accounts payable/receivable aging report utilities
|
||||||
|
;;
|
||||||
|
;; By Derek Atkins <warlord@MIT.EDU> taken from the original...
|
||||||
|
;; By Robert Merkel (rgmerk@mira.net)
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2 of
|
||||||
|
;; the License, or (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;; GNU General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this program; if not, contact:
|
||||||
|
;;
|
||||||
|
;; Free Software Foundation Voice: +1-617-542-5942
|
||||||
|
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||||
|
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||||
|
;;
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define-module (gnucash report aging))
|
||||||
|
|
||||||
|
(use-modules (ice-9 slib))
|
||||||
|
(use-modules (gnucash bootstrap))
|
||||||
|
(use-modules (gnucash gnc-module))
|
||||||
|
|
||||||
|
(require 'hash-table)
|
||||||
|
(require 'record)
|
||||||
|
|
||||||
|
(gnc:module-load "gnucash/report/report-system" 0)
|
||||||
|
|
||||||
|
(define sect-acc (N_ "Accounts"))
|
||||||
|
(define optname-to-date (N_ "To"))
|
||||||
|
(define optname-use-description (N_ "Use Description?"))
|
||||||
|
(define optname-sort-by (N_ "Sort By"))
|
||||||
|
(define optname-sort-order (N_ "Sort Order"))
|
||||||
|
(define optname-report-currency (N_ "Report's currency"))
|
||||||
|
(define optname-price-source (N_ "Price Source"))
|
||||||
|
(define optname-multicurrency-totals (N_ "Show Multi-currency Totals?"))
|
||||||
|
|
||||||
|
;; The idea is: have a hash with the key being the contact name
|
||||||
|
;; (In future this might be GUID'ed, but for now it's a string
|
||||||
|
;; from the description or the split memo.
|
||||||
|
;; The value is a record which contains the currency that contact
|
||||||
|
;; is stored in (you can only owe a particular contact one
|
||||||
|
;; currency, it just gets far too difficult otherwise), and a list
|
||||||
|
;; of buckets containing the money owed for each interval,
|
||||||
|
;; oldest first.
|
||||||
|
;; overpayment is just that - it stores the current overpayment,
|
||||||
|
;; if any. Any bills get taken out of the overpayment before
|
||||||
|
;; incurring debt.
|
||||||
|
|
||||||
|
(define company-info (make-record-type "ComanyInfo"
|
||||||
|
'(currency
|
||||||
|
bucket-vector
|
||||||
|
overpayment)))
|
||||||
|
|
||||||
|
(define num-buckets 4)
|
||||||
|
(define (new-bucket-vector)
|
||||||
|
(make-vector num-buckets (gnc:numeric-zero)))
|
||||||
|
|
||||||
|
(define make-company-private
|
||||||
|
(record-constructor company-info '(currency bucket-vector overpayment)))
|
||||||
|
|
||||||
|
(define (make-company currency)
|
||||||
|
(make-company-private currency (new-bucket-vector) (gnc:numeric-zero)))
|
||||||
|
|
||||||
|
(define company-get-currency
|
||||||
|
(record-accessor company-info 'currency))
|
||||||
|
|
||||||
|
(define company-get-buckets
|
||||||
|
(record-accessor company-info 'bucket-vector))
|
||||||
|
|
||||||
|
(define company-set-buckets
|
||||||
|
(record-modifier company-info 'bucket-vector))
|
||||||
|
|
||||||
|
(define company-get-overpayment
|
||||||
|
(record-accessor company-info 'overpayment))
|
||||||
|
|
||||||
|
(define company-set-overpayment
|
||||||
|
(record-modifier company-info 'overpayment))
|
||||||
|
|
||||||
|
;; Put an invoice in the appropriate bucket
|
||||||
|
|
||||||
|
(define (process-invoice company amount bucket-intervals date)
|
||||||
|
(define (in-interval this-date current-bucket)
|
||||||
|
(gnc:timepair-lt this-date current-bucket))
|
||||||
|
|
||||||
|
(define (find-bucket current-bucket bucket-intervals date)
|
||||||
|
(begin
|
||||||
|
(gnc:debug "current bucket" current-bucket)
|
||||||
|
(gnc:debug "bucket-intervals" bucket-intervals)
|
||||||
|
(gnc:debug "date" date)
|
||||||
|
(if (> current-bucket (vector-length bucket-intervals))
|
||||||
|
(gnc:error "sanity check failed in find-bucket")
|
||||||
|
(if (in-interval date (vector-ref bucket-intervals current-bucket))
|
||||||
|
current-bucket
|
||||||
|
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
|
||||||
|
|
||||||
|
(define (calculate-adjusted-values amount overpayment)
|
||||||
|
(if (>= (gnc:numeric-compare amount overpayment) 0)
|
||||||
|
(cons (gnc:numeric-sub-fixed amount overpayment)
|
||||||
|
(gnc:numeric-zero))
|
||||||
|
(cons (gnc:numeric-zero)
|
||||||
|
(gnc:numeric-sub-fixed overpayment amount))))
|
||||||
|
|
||||||
|
(let* ((current-overpayment (company-get-overpayment company))
|
||||||
|
(adjusted-values (calculate-adjusted-values amount current-overpayment))
|
||||||
|
(adjusted-amount (car adjusted-values))
|
||||||
|
(adjusted-overpayment (cdr adjusted-values))
|
||||||
|
(bucket-index (find-bucket 0 bucket-intervals date))
|
||||||
|
(buckets (company-get-buckets company))
|
||||||
|
(new-bucket-value
|
||||||
|
(gnc:numeric-add-fixed adjusted-amount (vector-ref buckets bucket-index))))
|
||||||
|
(vector-set! buckets bucket-index new-bucket-value)
|
||||||
|
(company-set-buckets company buckets)
|
||||||
|
(company-set-overpayment company adjusted-overpayment)))
|
||||||
|
|
||||||
|
|
||||||
|
;; NOTE: We assume that bill payments occur in a FIFO manner - ie
|
||||||
|
;; any payment to a company goes towards the *oldest* bill first
|
||||||
|
|
||||||
|
|
||||||
|
(define (process-payment company amount)
|
||||||
|
(define (process-payment-driver amount buckets current-bucket-index)
|
||||||
|
(if (>= current-bucket-index (vector-length buckets))
|
||||||
|
amount
|
||||||
|
(let ((current-bucket-amt (vector-ref buckets current-bucket-index)))
|
||||||
|
(if (>= (gnc:numeric-compare current-bucket-amt amount) 0)
|
||||||
|
(begin
|
||||||
|
(vector-set! buckets current-bucket-index (gnc:numeric-sub-fixed
|
||||||
|
current-bucket-amt amount))
|
||||||
|
(gnc:numeric-zero))
|
||||||
|
(begin
|
||||||
|
(vector-set! buckets current-bucket-index (gnc:numeric-zero))
|
||||||
|
(process-payment-driver
|
||||||
|
(gnc:numeric-sub-fixed amount current-bucket-amt)
|
||||||
|
buckets
|
||||||
|
(+ current-bucket-index 1)))))))
|
||||||
|
|
||||||
|
(let ((overpayment (company-get-overpayment company)))
|
||||||
|
;; if there's already an overpayment, make it bigger
|
||||||
|
(if (gnc:numeric-positive-p overpayment)
|
||||||
|
(company-set-overpayment company (gnc:numeric-add-fixed overpayment amount))
|
||||||
|
|
||||||
|
(let ((result (process-payment-driver amount (company-get-buckets company) 0)))
|
||||||
|
(company-set-overpayment company result)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;; deal with a transaction - figure out if we've seen the company before
|
||||||
|
;; if so, either process it as a bill or a payment, if not, create
|
||||||
|
;; a new company record in the hash
|
||||||
|
|
||||||
|
(define (update-company-hash hash split bucket-intervals
|
||||||
|
use-description? reverse?)
|
||||||
|
(let* ((transaction (gnc:split-get-parent split))
|
||||||
|
(company-name (if use-description?
|
||||||
|
(gnc:transaction-get-description transaction)
|
||||||
|
(gnc:split-get-memo split)))
|
||||||
|
(this-currency (gnc:transaction-get-currency transaction))
|
||||||
|
(value (gnc:split-get-value split))
|
||||||
|
(this-date (gnc:transaction-get-date-posted transaction))
|
||||||
|
(company-info (hash-ref hash company-name)))
|
||||||
|
|
||||||
|
(gnc:debug "update-company-hash called")
|
||||||
|
(gnc:debug "company-name" company-name)
|
||||||
|
(gnc:debug "split-value" value)
|
||||||
|
(if reverse? (set! value (gnc:numeric-neg value)))
|
||||||
|
(if company-info
|
||||||
|
;; if it's an existing company, first check currencies match
|
||||||
|
(if (not (gnc:commodity-equiv? this-currency
|
||||||
|
(company-get-currency company-info)))
|
||||||
|
(cons #f (sprintf (_ "Transactions relating to company %d contain \
|
||||||
|
more than one currency. This report is not designed to cope with this possibility.")))
|
||||||
|
(begin
|
||||||
|
(gnc:debug "it's an old company")
|
||||||
|
(if (gnc:numeric-negative-p value)
|
||||||
|
(process-invoice company-info (gnc:numeric-neg value) bucket-intervals this-date)
|
||||||
|
(process-payment company-info value))
|
||||||
|
(hash-set! hash company-name company-info)
|
||||||
|
(cons #t company-name)))
|
||||||
|
|
||||||
|
;; if it's a new company
|
||||||
|
(begin
|
||||||
|
(gnc:debug "value" value)
|
||||||
|
(if (gnc:numeric-negative-p value) ;; if it's a new debt
|
||||||
|
;; if not ignore it
|
||||||
|
;;; XXX: is this right ?
|
||||||
|
(let ((new-company (make-company this-currency)))
|
||||||
|
(process-invoice new-company (gnc:numeric-neg value) bucket-intervals this-date)
|
||||||
|
(hash-set! hash company-name new-company)))
|
||||||
|
(cons #t company-name)))))
|
||||||
|
|
||||||
|
|
||||||
|
;; get the total debt from the buckets
|
||||||
|
(define (buckets-get-total buckets)
|
||||||
|
(let ((running-total (gnc:numeric-zero))
|
||||||
|
(buckets-list (vector->list buckets)))
|
||||||
|
(for-each (lambda (bucket)
|
||||||
|
(set! running-total
|
||||||
|
(gnc:numeric-add-fixed bucket running-total)))
|
||||||
|
buckets-list)
|
||||||
|
running-total))
|
||||||
|
|
||||||
|
|
||||||
|
;; compare by the total in the buckets
|
||||||
|
|
||||||
|
(define (compare-total litem-a litem-b)
|
||||||
|
(let* ((company-a (cdr litem-a))
|
||||||
|
(bucket-a (company-get-buckets company-a))
|
||||||
|
(company-b (cdr litem-b))
|
||||||
|
(bucket-b (company-get-buckets company-b))
|
||||||
|
(total-a (buckets-get-total bucket-a))
|
||||||
|
(total-b (buckets-get-total bucket-b))
|
||||||
|
(difference-sign (gnc:numeric-compare (gnc:numeric-sub-fixed total-a total-b) (gnc:numeric-zero))))
|
||||||
|
;; if same totals, compare by name
|
||||||
|
(if (= difference-sign 0)
|
||||||
|
(gnc:safe-strcmp (car litem-a) (car litem-b))
|
||||||
|
difference-sign)))
|
||||||
|
|
||||||
|
;; compare by buckets, oldest first.
|
||||||
|
|
||||||
|
(define (compare-buckets litem-a litem-b)
|
||||||
|
(define (driver buckets-a buckets-b)
|
||||||
|
(if (null? buckets-a)
|
||||||
|
0
|
||||||
|
(let ((diff (gnc:numeric-compare
|
||||||
|
(gnc:numeric-sub-fixed
|
||||||
|
(car buckets-a)
|
||||||
|
(car buckets-b))
|
||||||
|
(gnc:numeric-zero))))
|
||||||
|
(if (= diff 0)
|
||||||
|
(driver (cdr buckets-a) (cdr buckets-b))
|
||||||
|
diff))))
|
||||||
|
|
||||||
|
(let* ((company-a (cdr litem-a))
|
||||||
|
(bucket-a (vector->list (company-get-buckets company-a)))
|
||||||
|
(company-b (cdr litem-b))
|
||||||
|
(bucket-b (vector->list (company-get-buckets company-b)))
|
||||||
|
|
||||||
|
(difference (driver bucket-a bucket-b)))
|
||||||
|
;; if same totals, compare by name
|
||||||
|
(if (= difference 0)
|
||||||
|
(gnc:safe-strcmp (car litem-a) (car litem-b))
|
||||||
|
difference)))
|
||||||
|
|
||||||
|
|
||||||
|
;; set up the query to get the splits in the chosen account
|
||||||
|
;; XXX: Need a better method to actually sort through the 'active'
|
||||||
|
;; transactions. Currently go back a year, but obviously we need
|
||||||
|
;; a way to tell that a transaction is 'paid'
|
||||||
|
;;; FIXME: begindate is a hack
|
||||||
|
(define (setup-query query account date)
|
||||||
|
(define (date-copy date)
|
||||||
|
(cons (car date) (cdr date)))
|
||||||
|
(let ((begindate (date-copy date)))
|
||||||
|
; (gnc:debug "Account: " account)
|
||||||
|
(set! begindate (decdate begindate NinetyDayDelta))
|
||||||
|
(set! begindate (decdate begindate NinetyDayDelta))
|
||||||
|
(set! begindate (decdate begindate NinetyDayDelta))
|
||||||
|
(set! begindate (decdate begindate NinetyDayDelta)) ;XXX - 360 days!?!
|
||||||
|
(gnc:debug "begindate" begindate)
|
||||||
|
(gnc:debug "date" date)
|
||||||
|
(gnc:query-set-group query (gnc:get-current-group))
|
||||||
|
(gnc:query-set-match-non-voids-only! query (gnc:get-current-group))
|
||||||
|
(gnc:query-add-single-account-match query account 'query-and)
|
||||||
|
(gnc:query-add-date-match-timepair query #t begindate #t date 'query-and)
|
||||||
|
(gnc:query-set-sort-order query 'by-date 'by-none 'by-none)
|
||||||
|
(gnc:query-set-sort-increasing query #t #t #t)))
|
||||||
|
|
||||||
|
|
||||||
|
(define (aging-options-generator options)
|
||||||
|
(let* ((add-option
|
||||||
|
(lambda (new-option)
|
||||||
|
(gnc:register-option options new-option))))
|
||||||
|
|
||||||
|
(gnc:options-add-report-date!
|
||||||
|
options gnc:pagename-general
|
||||||
|
optname-to-date "a")
|
||||||
|
|
||||||
|
;; all about currencies
|
||||||
|
(gnc:options-add-currency!
|
||||||
|
options gnc:pagename-general
|
||||||
|
optname-report-currency "b")
|
||||||
|
|
||||||
|
(gnc:options-add-price-source!
|
||||||
|
options gnc:pagename-general
|
||||||
|
optname-price-source "c" 'weighted-average)
|
||||||
|
|
||||||
|
(add-option
|
||||||
|
(gnc:make-multichoice-option
|
||||||
|
gnc:pagename-general
|
||||||
|
optname-sort-by
|
||||||
|
"i"
|
||||||
|
(N_ "Sort companys by")
|
||||||
|
'name
|
||||||
|
(list
|
||||||
|
(vector 'name (N_ "Name") (N_ "Name of the company"))
|
||||||
|
(vector 'total (N_ "Total Owed") (N_ "Total amount owed to/from Company"))
|
||||||
|
(vector 'oldest-bracket (N_ "Bracket Total Owed") (N_ "Amount owed in oldest bracket - if same go to next oldest")))))
|
||||||
|
|
||||||
|
(add-option
|
||||||
|
(gnc:make-multichoice-option
|
||||||
|
gnc:pagename-general
|
||||||
|
optname-sort-order
|
||||||
|
"ia"
|
||||||
|
(N_ "Sort order")
|
||||||
|
'increasing
|
||||||
|
(list
|
||||||
|
(vector 'increasing (N_ "Increasing") (N_ "0 -> $999,999.99, A->Z"))
|
||||||
|
(vector 'decreasing (N_ "Decreasing") (N_ "$999,999.99 -> $0, Z->A")))))
|
||||||
|
|
||||||
|
(add-option
|
||||||
|
(gnc:make-simple-boolean-option
|
||||||
|
gnc:pagename-general
|
||||||
|
optname-use-description
|
||||||
|
"h"
|
||||||
|
(N_ "Use the description to identify individual companys.\
|
||||||
|
If false, use split memo")
|
||||||
|
#t))
|
||||||
|
|
||||||
|
|
||||||
|
(add-option
|
||||||
|
(gnc:make-simple-boolean-option
|
||||||
|
gnc:pagename-general
|
||||||
|
optname-multicurrency-totals
|
||||||
|
"i"
|
||||||
|
(N_ "Show multi-currency totals. If not selected, convert all\
|
||||||
|
totals to report currency")
|
||||||
|
#f))
|
||||||
|
(gnc:options-set-default-section options "General")
|
||||||
|
options))
|
||||||
|
|
||||||
|
(define (make-interval-list to-date)
|
||||||
|
(let ((begindate to-date))
|
||||||
|
(set! begindate (decdate begindate ThirtyDayDelta))
|
||||||
|
(set! begindate (decdate begindate ThirtyDayDelta))
|
||||||
|
(set! begindate (decdate begindate ThirtyDayDelta))
|
||||||
|
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
|
||||||
|
|
||||||
|
(define (aging-renderer report-obj account reverse?)
|
||||||
|
|
||||||
|
;; Predicates for sorting the companys once the data has been collected
|
||||||
|
|
||||||
|
;; Format: (cons 'sort-key (cons 'increasing-pred 'decreasing-pred))
|
||||||
|
(define sort-preds
|
||||||
|
(list
|
||||||
|
(cons 'name (cons (lambda (a b)
|
||||||
|
(string<? (car a) (car b)))
|
||||||
|
(lambda (a b)
|
||||||
|
(string>? (car a) (car b)))))
|
||||||
|
(cons 'total (cons (lambda (a b)
|
||||||
|
(< (compare-total a b) 0))
|
||||||
|
(lambda (a b)
|
||||||
|
(> (compare-total a b) 0))))
|
||||||
|
(cons 'oldest-bracket (cons
|
||||||
|
(lambda (a b)
|
||||||
|
(< (compare-buckets a b) 0))
|
||||||
|
(lambda (a b)
|
||||||
|
(> (compare-buckets a b) 0))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(define (get-sort-pred sort-criterion sort-order)
|
||||||
|
(let ((choice (assq-ref sort-preds sort-criterion)))
|
||||||
|
(gnc:debug "sort-criterion" sort-criterion)
|
||||||
|
(gnc:debug "sort-order" sort-order)
|
||||||
|
(gnc:debug "choice: " choice)
|
||||||
|
(if choice
|
||||||
|
(if (eq? sort-order 'increasing)
|
||||||
|
(car choice)
|
||||||
|
(cdr choice))
|
||||||
|
(begin
|
||||||
|
(gnc:warn "internal sorting option errorin aging.scm")
|
||||||
|
(lambda (a b)
|
||||||
|
(string<? (car a) (car b)))))))
|
||||||
|
|
||||||
|
(define (get-op section name)
|
||||||
|
(gnc:lookup-option (gnc:report-options report-obj) section name))
|
||||||
|
|
||||||
|
(define (op-value section name)
|
||||||
|
(gnc:option-value (get-op section name)))
|
||||||
|
|
||||||
|
|
||||||
|
;; XXX: This is a hack - will be fixed when we move to a
|
||||||
|
;; more general interval scheme in this report
|
||||||
|
(define (make-heading-list)
|
||||||
|
(list
|
||||||
|
(N_ "Company")
|
||||||
|
(N_ "0-30 days")
|
||||||
|
(N_ "31-60 days")
|
||||||
|
(N_ "61-90 days")
|
||||||
|
(N_ "91+ days")
|
||||||
|
(N_ "Total")))
|
||||||
|
|
||||||
|
|
||||||
|
;; Make a list of commodity collectors for column totals
|
||||||
|
|
||||||
|
(define (make-collector-list)
|
||||||
|
(define (make-collector-driver done total)
|
||||||
|
(if (< done total)
|
||||||
|
(cons
|
||||||
|
(gnc:make-commodity-collector)
|
||||||
|
(make-collector-driver (+ done 1) total))
|
||||||
|
'()))
|
||||||
|
(make-collector-driver 0 (+ num-buckets 1)))
|
||||||
|
|
||||||
|
|
||||||
|
;; update the column totals
|
||||||
|
|
||||||
|
(define (add-to-column-totals column-totals monetary-list)
|
||||||
|
(begin
|
||||||
|
(gnc:debug "column-totals" column-totals)
|
||||||
|
(gnc:debug "monetary-list" monetary-list)
|
||||||
|
(map (lambda (amount collector)
|
||||||
|
(begin
|
||||||
|
(gnc:debug "amount" amount)
|
||||||
|
(gnc:debug "collector" collector)
|
||||||
|
(collector 'add
|
||||||
|
(gnc:gnc-monetary-commodity amount)
|
||||||
|
(gnc:gnc-monetary-amount amount))))
|
||||||
|
monetary-list
|
||||||
|
column-totals)))
|
||||||
|
|
||||||
|
;; convert the buckets in the header data structure
|
||||||
|
(define (convert-to-monetary-list bucket-list currency)
|
||||||
|
(let* ((running-total (gnc:numeric-zero))
|
||||||
|
(monetised-buckets
|
||||||
|
(map (lambda (bucket-list-entry)
|
||||||
|
(begin
|
||||||
|
(set! running-total
|
||||||
|
(gnc:numeric-add-fixed running-total bucket-list-entry))
|
||||||
|
(gnc:make-gnc-monetary currency bucket-list-entry)))
|
||||||
|
(vector->list bucket-list))))
|
||||||
|
(append (reverse monetised-buckets)
|
||||||
|
(list (gnc:make-gnc-monetary currency running-total)))))
|
||||||
|
|
||||||
|
|
||||||
|
;; convert the collectors to the right output format
|
||||||
|
|
||||||
|
(define (convert-collectors collector-list report-currency
|
||||||
|
exchange-fn
|
||||||
|
multi-currencies-p)
|
||||||
|
(define (fmt-one-currency collector)
|
||||||
|
(let ((monetary (gnc:sum-collector-commodity collector report-currency exchange-fn)))
|
||||||
|
(if monetary
|
||||||
|
monetary
|
||||||
|
(begin
|
||||||
|
(gnc:warn "Exchange-lookup failed in fmt-one-currency")
|
||||||
|
#f))))
|
||||||
|
|
||||||
|
(define (fmt-multiple-currencies collector)
|
||||||
|
(let ((mini-table (gnc:make-html-table)))
|
||||||
|
(collector 'format
|
||||||
|
(lambda (commodity amount)
|
||||||
|
(gnc:html-table-append-row!
|
||||||
|
mini-table
|
||||||
|
(list (gnc:make-gnc-monetary
|
||||||
|
commodity amount))))
|
||||||
|
#f)
|
||||||
|
mini-table))
|
||||||
|
|
||||||
|
(let ((fmt-function
|
||||||
|
(if multi-currencies-p
|
||||||
|
fmt-multiple-currencies
|
||||||
|
fmt-one-currency)))
|
||||||
|
(map fmt-function collector-list)))
|
||||||
|
|
||||||
|
|
||||||
|
(let* ((companys (make-hash-table 23))
|
||||||
|
(report-title (op-value gnc:pagename-general
|
||||||
|
gnc:optname-reportname))
|
||||||
|
;; document will be the HTML document that we return.
|
||||||
|
(report-date (gnc:timepair-end-day-time
|
||||||
|
(gnc:date-option-absolute-time
|
||||||
|
(op-value gnc:pagename-general (N_ "To")))))
|
||||||
|
(use-description? (op-value gnc:pagename-general optname-use-description))
|
||||||
|
(interval-vec (list->vector (make-interval-list report-date)))
|
||||||
|
(sort-pred (get-sort-pred
|
||||||
|
(op-value gnc:pagename-general optname-sort-by)
|
||||||
|
(op-value gnc:pagename-general optname-sort-order)))
|
||||||
|
(report-currency (op-value gnc:pagename-general optname-report-currency))
|
||||||
|
(price-source (op-value gnc:pagename-general optname-price-source))
|
||||||
|
(multi-totals-p (op-value gnc:pagename-general optname-multicurrency-totals))
|
||||||
|
(heading-list (make-heading-list))
|
||||||
|
(exchange-fn (gnc:case-exchange-fn price-source report-currency report-date))
|
||||||
|
(total-collector-list (make-collector-list))
|
||||||
|
(table (gnc:make-html-table))
|
||||||
|
(query (gnc:malloc-query))
|
||||||
|
(company-list '())
|
||||||
|
(document (gnc:make-html-document)))
|
||||||
|
; (gnc:debug "Account: " account)
|
||||||
|
(gnc:html-document-set-title! document report-title)
|
||||||
|
(gnc:html-table-set-col-headers! table heading-list)
|
||||||
|
|
||||||
|
(if account
|
||||||
|
(begin
|
||||||
|
(setup-query query account report-date)
|
||||||
|
;; get the appropriate splits
|
||||||
|
(let ((splits (gnc:glist->list (gnc:query-get-splits query) <gnc:Split*>)))
|
||||||
|
; (gnc:debug "splits" splits)
|
||||||
|
|
||||||
|
;; build the table
|
||||||
|
(for-each (lambda (split)
|
||||||
|
(update-company-hash companys
|
||||||
|
split
|
||||||
|
interval-vec
|
||||||
|
use-description?
|
||||||
|
reverse?))
|
||||||
|
splits)
|
||||||
|
; (gnc:debug "companys" companys)
|
||||||
|
;; turn the hash into a list
|
||||||
|
(hash-for-each (lambda (key value)
|
||||||
|
(set! company-list
|
||||||
|
(cons (cons key value) company-list)))
|
||||||
|
companys)
|
||||||
|
; (gnc:debug "company list" company-list)
|
||||||
|
|
||||||
|
(set! company-list (sort-list! company-list
|
||||||
|
sort-pred))
|
||||||
|
|
||||||
|
;; build the table
|
||||||
|
(for-each (lambda (company-list-entry)
|
||||||
|
(let ((monetary-list (convert-to-monetary-list
|
||||||
|
(company-get-buckets
|
||||||
|
(cdr company-list-entry))
|
||||||
|
(company-get-currency
|
||||||
|
(cdr company-list-entry)))))
|
||||||
|
(add-to-column-totals total-collector-list monetary-list)
|
||||||
|
(gnc:html-table-append-row!
|
||||||
|
table (cons (car company-list-entry) monetary-list))))
|
||||||
|
company-list)
|
||||||
|
|
||||||
|
;; add the totals
|
||||||
|
(gnc:html-table-append-row!
|
||||||
|
table
|
||||||
|
(cons (_ "Total") (convert-collectors total-collector-list
|
||||||
|
report-currency
|
||||||
|
exchange-fn
|
||||||
|
multi-totals-p)))
|
||||||
|
|
||||||
|
(gnc:html-document-add-object!
|
||||||
|
document table)))
|
||||||
|
(gnc:html-document-add-object!
|
||||||
|
document
|
||||||
|
(gnc:make-html-text
|
||||||
|
"No Valid Account Selected")))
|
||||||
|
(gnc:free-query query)
|
||||||
|
document))
|
||||||
|
|
||||||
|
(export aging-options-generator)
|
||||||
|
(export aging-renderer)
|
||||||
@ -1,7 +1,7 @@
|
|||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; payables.scm : accounts payable report
|
;; payables.scm : accounts payable aging report
|
||||||
;;
|
;;
|
||||||
;; By Robert Merkel (rgmerk@mira.net)
|
;; By Derek Atkins <warlord@MIT.EDU>
|
||||||
;;
|
;;
|
||||||
;; This program is free software; you can redistribute it and/or
|
;; This program is free software; you can redistribute it and/or
|
||||||
;; modify it under the terms of the GNU General Public License as
|
;; modify it under the terms of the GNU General Public License as
|
||||||
@ -25,255 +25,15 @@
|
|||||||
(define-module (gnucash report payables))
|
(define-module (gnucash report payables))
|
||||||
|
|
||||||
(use-modules (ice-9 slib))
|
(use-modules (ice-9 slib))
|
||||||
(use-modules (gnucash bootstrap) (g-wrapped gw-gnc)) ;; FIXME: delete after we finish modularizing.
|
(use-modules (gnucash bootstrap))
|
||||||
(use-modules (gnucash gnc-module))
|
(use-modules (gnucash gnc-module))
|
||||||
|
|
||||||
(require 'hash-table)
|
|
||||||
(require 'record)
|
|
||||||
|
|
||||||
(gnc:module-load "gnucash/report/report-system" 0)
|
(gnc:module-load "gnucash/report/report-system" 0)
|
||||||
|
|
||||||
|
(use-modules (gnucash report aging))
|
||||||
|
|
||||||
(define opt-pay-acc (N_ "Payables Account"))
|
(define opt-pay-acc (N_ "Payables Account"))
|
||||||
(define sect-acc (N_ "Accounts"))
|
(define sect-acc (N_ "Accounts"))
|
||||||
(define optname-to-date (N_ "To"))
|
|
||||||
(define optname-use-description (N_ "Use Description?"))
|
|
||||||
(define optname-sort-by (N_ "Sort By"))
|
|
||||||
(define optname-sort-order (N_ "Sort Order"))
|
|
||||||
(define optname-report-currency (N_ "Report's currency"))
|
|
||||||
(define optname-price-source (N_ "Price Source"))
|
|
||||||
(define optname-multicurrency-totals (N_ "Show Multi-currency Totals?"))
|
|
||||||
|
|
||||||
;; The idea is: have a hash with the key being the creditor name
|
|
||||||
;; (In future this might be GUID'ed, but for now it's a string
|
|
||||||
;; from the description or the split memo.
|
|
||||||
;; The value is a record which contains the currency that creditor
|
|
||||||
;; is stored in (you can only owe a particular creditor one
|
|
||||||
;; currency, it just gets far too difficult otherwise), and a list
|
|
||||||
;; of buckets containing the money owed for each interval,
|
|
||||||
;; oldest first.
|
|
||||||
;; overpayment is just that - it stores the current overpayment,
|
|
||||||
;; if any. Any bills get taken out of the overpayment before
|
|
||||||
;; incurring debt.
|
|
||||||
|
|
||||||
(define creditor-info (make-record-type "CreditorInfo"
|
|
||||||
'(currency
|
|
||||||
bucket-vector
|
|
||||||
overpayment)))
|
|
||||||
|
|
||||||
(define num-buckets 4)
|
|
||||||
(define (new-bucket-vector)
|
|
||||||
(make-vector num-buckets (gnc:numeric-zero)))
|
|
||||||
|
|
||||||
(define make-creditor-private
|
|
||||||
(record-constructor creditor-info '(currency bucket-vector
|
|
||||||
overpayment)))
|
|
||||||
|
|
||||||
(define (make-creditor currency)
|
|
||||||
(make-creditor-private currency (new-bucket-vector)
|
|
||||||
(gnc:numeric-zero)))
|
|
||||||
|
|
||||||
(define creditor-get-currency
|
|
||||||
(record-accessor creditor-info 'currency))
|
|
||||||
|
|
||||||
(define creditor-get-buckets
|
|
||||||
(record-accessor creditor-info 'bucket-vector))
|
|
||||||
|
|
||||||
(define creditor-set-buckets
|
|
||||||
(record-modifier creditor-info 'bucket-vector))
|
|
||||||
|
|
||||||
(define creditor-get-overpayment
|
|
||||||
(record-accessor creditor-info 'overpayment))
|
|
||||||
|
|
||||||
(define creditor-set-overpayment
|
|
||||||
(record-modifier creditor-info 'overpayment))
|
|
||||||
|
|
||||||
;; Put a bill in the appropriate bucket
|
|
||||||
|
|
||||||
(define (process-bill creditor amount bucket-intervals date)
|
|
||||||
(define (in-interval this-date current-bucket)
|
|
||||||
(gnc:timepair-lt this-date current-bucket))
|
|
||||||
|
|
||||||
(define (find-bucket current-bucket bucket-intervals date)
|
|
||||||
(begin
|
|
||||||
(gnc:debug "current bucket" current-bucket)
|
|
||||||
(gnc:debug "bucket-intervals" bucket-intervals)
|
|
||||||
(gnc:debug "date" date)
|
|
||||||
(if (> current-bucket (vector-length bucket-intervals))
|
|
||||||
(gnc:error "sanity check failed in find-bucket")
|
|
||||||
(if (in-interval date (vector-ref bucket-intervals current-bucket))
|
|
||||||
current-bucket
|
|
||||||
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
|
|
||||||
|
|
||||||
(define (calculate-adjusted-values amount overpayment)
|
|
||||||
(if (>= (gnc:numeric-compare amount overpayment) 0)
|
|
||||||
(cons (gnc:numeric-sub-fixed amount overpayment)
|
|
||||||
(gnc:numeric-zero))
|
|
||||||
(cons (gnc:numeric-zero)
|
|
||||||
(gnc:numeric-sub-fixed overpayment amount))))
|
|
||||||
|
|
||||||
(let* ((current-overpayment (creditor-get-overpayment creditor))
|
|
||||||
(adjusted-values (calculate-adjusted-values amount current-overpayment))
|
|
||||||
(adjusted-amount (car adjusted-values))
|
|
||||||
(adjusted-overpayment (cdr adjusted-values))
|
|
||||||
(bucket-index (find-bucket 0 bucket-intervals date))
|
|
||||||
(buckets (creditor-get-buckets creditor))
|
|
||||||
(new-bucket-value
|
|
||||||
(gnc:numeric-add-fixed adjusted-amount (vector-ref buckets bucket-index))))
|
|
||||||
(vector-set! buckets bucket-index new-bucket-value)
|
|
||||||
(creditor-set-buckets creditor buckets)
|
|
||||||
(creditor-set-overpayment creditor adjusted-overpayment)))
|
|
||||||
|
|
||||||
|
|
||||||
;; NOTE: We assume that bill payments occur in a FIFO manner - ie
|
|
||||||
;; any payment to a creditor goes towards the *oldest* bill first
|
|
||||||
|
|
||||||
|
|
||||||
(define (process-payment creditor amount)
|
|
||||||
(define (process-payment-driver amount buckets current-bucket-index)
|
|
||||||
(if (>= current-bucket-index (vector-length buckets))
|
|
||||||
amount
|
|
||||||
(let ((current-bucket-amt (vector-ref buckets current-bucket-index)))
|
|
||||||
(if (>= (gnc:numeric-compare current-bucket-amt amount) 0)
|
|
||||||
(begin
|
|
||||||
(vector-set! buckets current-bucket-index (gnc:numeric-sub-fixed
|
|
||||||
current-bucket-amt amount))
|
|
||||||
(gnc:numeric-zero))
|
|
||||||
(begin
|
|
||||||
(vector-set! buckets current-bucket-index (gnc:numeric-zero))
|
|
||||||
(process-payment-driver
|
|
||||||
(gnc:numeric-sub-fixed amount current-bucket-amt)
|
|
||||||
buckets
|
|
||||||
(+ current-bucket-index 1)))))))
|
|
||||||
|
|
||||||
(let ((overpayment (creditor-get-overpayment creditor)))
|
|
||||||
;; if there's already an overpayment, make it bigger
|
|
||||||
(if (gnc:numeric-positive-p overpayment)
|
|
||||||
(creditor-set-overpayment creditor (gnc:numeric-add-fixed overpayment amount))
|
|
||||||
|
|
||||||
(let ((result (process-payment-driver amount (creditor-get-buckets creditor) 0)))
|
|
||||||
(creditor-set-overpayment creditor result)))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;; deal with a transaction - figure out if we've seen the creditor before
|
|
||||||
;; if so, either process it as a bill or a payment, if not, create
|
|
||||||
;; a new creditor record in the hash
|
|
||||||
|
|
||||||
(define (update-creditor-hash hash split bucket-intervals use-description?)
|
|
||||||
(let* ((transaction (gnc:split-get-parent split))
|
|
||||||
(creditor-name (if use-description?
|
|
||||||
(gnc:transaction-get-description transaction)
|
|
||||||
(gnc:split-get-memo split)))
|
|
||||||
(this-currency (gnc:transaction-get-currency transaction))
|
|
||||||
(value (gnc:split-get-value split))
|
|
||||||
(this-date (gnc:transaction-get-date-posted transaction))
|
|
||||||
(creditor-info (hash-ref hash creditor-name)))
|
|
||||||
|
|
||||||
(gnc:debug "update-creditor-hash called")
|
|
||||||
(gnc:debug "creditor-name" creditor-name)
|
|
||||||
(gnc:debug "split-value" value)
|
|
||||||
(if creditor-info
|
|
||||||
;; if it's an existing creditor, first check currencies match
|
|
||||||
(if (not (gnc:commodity-equiv? this-currency
|
|
||||||
(creditor-get-currency creditor-info)))
|
|
||||||
(cons #f (sprintf (_ "Transactions relating to creditor %d contain \
|
|
||||||
more than one currency. This report is not designed to cope with this possibility.")))
|
|
||||||
(begin
|
|
||||||
(gnc:debug "it's an old creditor")
|
|
||||||
(if (gnc:numeric-negative-p value)
|
|
||||||
(process-bill creditor-info (gnc:numeric-neg value) bucket-intervals this-date)
|
|
||||||
(process-payment creditor-info value))
|
|
||||||
(hash-set! hash creditor-name creditor-info)
|
|
||||||
(cons #t creditor-name)))
|
|
||||||
|
|
||||||
;; if it's a new creditor
|
|
||||||
(begin
|
|
||||||
(gnc:debug "value" value)
|
|
||||||
(if (gnc:numeric-negative-p value) ;; if it's a new debt
|
|
||||||
;; if not ignore it
|
|
||||||
;;; XXX: is this right ?
|
|
||||||
(let ((new-creditor (make-creditor this-currency)))
|
|
||||||
(process-bill new-creditor (gnc:numeric-neg value) bucket-intervals this-date)
|
|
||||||
(hash-set! hash creditor-name new-creditor)))
|
|
||||||
(cons #t creditor-name)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; get the total debt from the buckets
|
|
||||||
(define (buckets-get-total buckets)
|
|
||||||
(let ((running-total (gnc:numeric-zero))
|
|
||||||
(buckets-list (vector->list buckets)))
|
|
||||||
(for-each (lambda (bucket)
|
|
||||||
(set! running-total
|
|
||||||
(gnc:numeric-add-fixed bucket running-total)))
|
|
||||||
buckets-list)
|
|
||||||
running-total))
|
|
||||||
|
|
||||||
|
|
||||||
;; compare by the total in the buckets
|
|
||||||
|
|
||||||
(define (compare-total litem-a litem-b)
|
|
||||||
(let* ((creditor-a (cdr litem-a))
|
|
||||||
(bucket-a (creditor-get-buckets creditor-a))
|
|
||||||
(creditor-b (cdr litem-b))
|
|
||||||
(bucket-b (creditor-get-buckets creditor-b))
|
|
||||||
(total-a (buckets-get-total bucket-a))
|
|
||||||
(total-b (buckets-get-total bucket-b))
|
|
||||||
(difference-sign (gnc:numeric-compare (gnc:numeric-sub-fixed total-a total-b) (gnc:numeric-zero))))
|
|
||||||
;; if same totals, compare by name
|
|
||||||
(if (= difference-sign 0)
|
|
||||||
(gnc:safe-strcmp (car litem-a) (car litem-b))
|
|
||||||
difference-sign)))
|
|
||||||
|
|
||||||
;; compare by buckets, oldest first.
|
|
||||||
|
|
||||||
(define (compare-buckets litem-a litem-b)
|
|
||||||
(define (driver buckets-a buckets-b)
|
|
||||||
(if (null? buckets-a)
|
|
||||||
0
|
|
||||||
(let ((diff (gnc:numeric-compare
|
|
||||||
(gnc:numeric-sub-fixed
|
|
||||||
(car buckets-a)
|
|
||||||
(car buckets-b))
|
|
||||||
(gnc:numeric-zero))))
|
|
||||||
(if (= diff 0)
|
|
||||||
(driver (cdr buckets-a) (cdr buckets-b))
|
|
||||||
diff))))
|
|
||||||
|
|
||||||
(let* ((creditor-a (cdr litem-a))
|
|
||||||
(bucket-a (vector->list (creditor-get-buckets creditor-a)))
|
|
||||||
(creditor-b (cdr litem-b))
|
|
||||||
(bucket-b (vector->list (creditor-get-buckets creditor-b)))
|
|
||||||
|
|
||||||
(difference (driver bucket-a bucket-b)))
|
|
||||||
;; if same totals, compare by name
|
|
||||||
(if (= difference 0)
|
|
||||||
(gnc:safe-strcmp (car litem-a) (car litem-b))
|
|
||||||
difference)))
|
|
||||||
|
|
||||||
|
|
||||||
;; set up the query to get the splits in the payables account
|
|
||||||
;; XXX: Need a better method to actually sort through the 'active'
|
|
||||||
;; transactions. Currently go back a year, but obviously we need
|
|
||||||
;; a way to tell that a transaction is 'paid'
|
|
||||||
(define (setup-query query account date)
|
|
||||||
(define (date-copy date)
|
|
||||||
(cons (car date) (cdr date)))
|
|
||||||
(let ((begindate (date-copy date)))
|
|
||||||
; (gnc:debug "Account: " account)
|
|
||||||
(set! begindate (decdate begindate NinetyDayDelta))
|
|
||||||
(set! begindate (decdate begindate NinetyDayDelta))
|
|
||||||
(set! begindate (decdate begindate NinetyDayDelta))
|
|
||||||
(set! begindate (decdate begindate NinetyDayDelta)) ;XXX - 360 days!?!
|
|
||||||
(gnc:debug "begindate" begindate)
|
|
||||||
(gnc:debug "date" date)
|
|
||||||
(gnc:query-set-group query (gnc:get-current-group))
|
|
||||||
(gnc:query-set-match-non-voids-only! query (gnc:get-current-group))
|
|
||||||
(gnc:query-add-single-account-match query account 'query-and)
|
|
||||||
(gnc:query-add-date-match-timepair query #t begindate #t date 'query-and)
|
|
||||||
(gnc:query-set-sort-order query 'by-date 'by-none 'by-none)
|
|
||||||
(gnc:query-set-sort-increasing query #t #t #t)))
|
|
||||||
|
|
||||||
|
|
||||||
(define (options-generator)
|
(define (options-generator)
|
||||||
(let* ((options (gnc:new-options))
|
(let* ((options (gnc:new-options))
|
||||||
@ -281,19 +41,6 @@ more than one currency. This report is not designed to cope with this possibili
|
|||||||
(lambda (new-option)
|
(lambda (new-option)
|
||||||
(gnc:register-option options new-option))))
|
(gnc:register-option options new-option))))
|
||||||
|
|
||||||
(gnc:options-add-report-date!
|
|
||||||
options gnc:pagename-general
|
|
||||||
optname-to-date "a")
|
|
||||||
|
|
||||||
;; all about currencies
|
|
||||||
(gnc:options-add-currency!
|
|
||||||
options gnc:pagename-general
|
|
||||||
optname-report-currency "b")
|
|
||||||
|
|
||||||
(gnc:options-add-price-source!
|
|
||||||
options gnc:pagename-general
|
|
||||||
optname-price-source "c" 'weighted-average)
|
|
||||||
|
|
||||||
(add-option
|
(add-option
|
||||||
(gnc:make-account-list-option
|
(gnc:make-account-list-option
|
||||||
sect-acc opt-pay-acc
|
sect-acc opt-pay-acc
|
||||||
@ -349,268 +96,18 @@ more than one currency. This report is not designed to cope with this possibili
|
|||||||
(#t '()))))
|
(#t '()))))
|
||||||
#f))
|
#f))
|
||||||
|
|
||||||
(add-option
|
(aging-options-generator options)))
|
||||||
(gnc:make-multichoice-option
|
|
||||||
gnc:pagename-general
|
|
||||||
optname-sort-by
|
|
||||||
"i"
|
|
||||||
(N_ "Sort creditors by")
|
|
||||||
'name
|
|
||||||
(list
|
|
||||||
(vector 'name (N_ "Name") (N_ "Name of the creditor"))
|
|
||||||
(vector 'total (N_ "Total Owed") (N_ "Total amount owed to Creditor"))
|
|
||||||
(vector 'oldest-bracket (N_ "Bracket Total Owed") (N_ "Amount owed in oldest bracket - if same go to next oldest")))))
|
|
||||||
|
|
||||||
(add-option
|
|
||||||
(gnc:make-multichoice-option
|
|
||||||
gnc:pagename-general
|
|
||||||
optname-sort-order
|
|
||||||
"ia"
|
|
||||||
(N_ "Sort order")
|
|
||||||
'increasing
|
|
||||||
(list
|
|
||||||
(vector 'increasing (N_ "Increasing") (N_ "0 -> $999,999.99, A->Z"))
|
|
||||||
(vector 'decreasing (N_ "Decreasing") (N_ "$999,999.99 -> $0, Z->A")))))
|
|
||||||
|
|
||||||
(add-option
|
|
||||||
(gnc:make-simple-boolean-option
|
|
||||||
gnc:pagename-general
|
|
||||||
optname-use-description
|
|
||||||
"h"
|
|
||||||
(N_ "Use the description to identify individual creditors.\
|
|
||||||
If false, use split memo")
|
|
||||||
#t))
|
|
||||||
|
|
||||||
|
|
||||||
(add-option
|
|
||||||
(gnc:make-simple-boolean-option
|
|
||||||
gnc:pagename-general
|
|
||||||
optname-multicurrency-totals
|
|
||||||
"i"
|
|
||||||
(N_ "Show multi-currency totals. If not selected, convert all\
|
|
||||||
totals to report currency")
|
|
||||||
#f))
|
|
||||||
(gnc:options-set-default-section options "General")
|
|
||||||
options))
|
|
||||||
|
|
||||||
(define (make-interval-list to-date)
|
|
||||||
(let ((begindate to-date))
|
|
||||||
(set! begindate (decdate begindate ThirtyDayDelta))
|
|
||||||
(set! begindate (decdate begindate ThirtyDayDelta))
|
|
||||||
(set! begindate (decdate begindate ThirtyDayDelta))
|
|
||||||
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
|
|
||||||
|
|
||||||
(define (payables-renderer report-obj)
|
(define (payables-renderer report-obj)
|
||||||
|
|
||||||
;; Predicates for sorting the creditors once the data has been collected
|
|
||||||
|
|
||||||
;; Format: (cons 'sort-key (cons 'increasing-pred 'decreasing-pred))
|
|
||||||
(define sort-preds
|
|
||||||
(list
|
|
||||||
(cons 'name (cons (lambda (a b)
|
|
||||||
(string<? (car a) (car b)))
|
|
||||||
(lambda (a b)
|
|
||||||
(string>? (car a) (car b)))))
|
|
||||||
(cons 'total (cons (lambda (a b)
|
|
||||||
(< (compare-total a b) 0))
|
|
||||||
(lambda (a b)
|
|
||||||
(> (compare-total a b) 0))))
|
|
||||||
(cons 'oldest-bracket (cons
|
|
||||||
(lambda (a b)
|
|
||||||
(< (compare-buckets a b) 0))
|
|
||||||
(lambda (a b)
|
|
||||||
(> (compare-buckets a b) 0))))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define (get-sort-pred sort-criterion sort-order)
|
|
||||||
(let ((choice (assq-ref sort-preds sort-criterion)))
|
|
||||||
(gnc:debug "sort-criterion" sort-criterion)
|
|
||||||
(gnc:debug "sort-order" sort-order)
|
|
||||||
(gnc:debug "choice: " choice)
|
|
||||||
(if choice
|
|
||||||
(if (eq? sort-order 'increasing)
|
|
||||||
(car choice)
|
|
||||||
(cdr choice))
|
|
||||||
(begin
|
|
||||||
(gnc:warn "internal sorting option errorin payables.scm")
|
|
||||||
(lambda (a b)
|
|
||||||
(string<? (car a) (car b)))))))
|
|
||||||
|
|
||||||
(define (get-op section name)
|
(define (get-op section name)
|
||||||
(gnc:lookup-option (gnc:report-options report-obj) section name))
|
(gnc:lookup-option (gnc:report-options report-obj) section name))
|
||||||
|
|
||||||
(define (op-value section name)
|
(define (op-value section name)
|
||||||
(gnc:option-value (get-op section name)))
|
(gnc:option-value (get-op section name)))
|
||||||
|
|
||||||
|
(let* ((payables-account (car (op-value sect-acc opt-pay-acc))))
|
||||||
;; XXX: This is a hack - will be fixed when we move to a
|
(aging-renderer report-obj payables-account #f)))
|
||||||
;; more general interval scheme in this report
|
|
||||||
(define (make-heading-list)
|
|
||||||
(list
|
|
||||||
(N_ "Creditor Name")
|
|
||||||
(N_ "0-30 days")
|
|
||||||
(N_ "31-60 days")
|
|
||||||
(N_ "61-90 days")
|
|
||||||
(N_ "91+ days")
|
|
||||||
(N_ "Total")))
|
|
||||||
|
|
||||||
|
|
||||||
;; Make a list of commodity collectors for column totals
|
|
||||||
|
|
||||||
;; XXX: Magic number is a hack
|
|
||||||
(define (make-collector-list)
|
|
||||||
(define (make-collector-driver done total)
|
|
||||||
(if (< done total)
|
|
||||||
(cons
|
|
||||||
(gnc:make-commodity-collector)
|
|
||||||
(make-collector-driver (+ done 1) total))
|
|
||||||
'()))
|
|
||||||
(make-collector-driver 0 5))
|
|
||||||
|
|
||||||
|
|
||||||
;; update the column totals
|
|
||||||
|
|
||||||
(define (add-to-column-totals column-totals monetary-list)
|
|
||||||
(begin
|
|
||||||
(gnc:debug "column-totals" column-totals)
|
|
||||||
(gnc:debug "monetary-list" monetary-list)
|
|
||||||
(map (lambda (amount collector)
|
|
||||||
(begin
|
|
||||||
(gnc:debug "amount" amount)
|
|
||||||
(gnc:debug "collector" collector)
|
|
||||||
(collector 'add
|
|
||||||
(gnc:gnc-monetary-commodity amount)
|
|
||||||
(gnc:gnc-monetary-amount amount))))
|
|
||||||
monetary-list
|
|
||||||
column-totals)))
|
|
||||||
|
|
||||||
;; convert the buckets in the header data structure
|
|
||||||
(define (convert-to-monetary-list bucket-list currency)
|
|
||||||
(let* ((running-total (gnc:numeric-zero))
|
|
||||||
(monetised-buckets
|
|
||||||
(map (lambda (bucket-list-entry)
|
|
||||||
(begin
|
|
||||||
(set! running-total
|
|
||||||
(gnc:numeric-add-fixed running-total bucket-list-entry))
|
|
||||||
(gnc:make-gnc-monetary currency bucket-list-entry)))
|
|
||||||
(vector->list bucket-list))))
|
|
||||||
(append (reverse monetised-buckets)
|
|
||||||
(list (gnc:make-gnc-monetary currency running-total)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; convert the collectors to the right output format
|
|
||||||
|
|
||||||
(define (convert-collectors collector-list report-currency
|
|
||||||
exchange-fn
|
|
||||||
multi-currencies-p)
|
|
||||||
(define (fmt-one-currency collector)
|
|
||||||
(let ((monetary (gnc:sum-collector-commodity collector report-currency exchange-fn)))
|
|
||||||
(if monetary
|
|
||||||
monetary
|
|
||||||
(begin
|
|
||||||
(gnc:warn "Exchange-lookup failed in fmt-one-currency")
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define (fmt-multiple-currencies collector)
|
|
||||||
(let ((mini-table (gnc:make-html-table)))
|
|
||||||
(collector 'format
|
|
||||||
(lambda (commodity amount)
|
|
||||||
(gnc:html-table-append-row!
|
|
||||||
mini-table
|
|
||||||
(list (gnc:make-gnc-monetary
|
|
||||||
commodity amount))))
|
|
||||||
#f)
|
|
||||||
mini-table))
|
|
||||||
|
|
||||||
(let ((fmt-function
|
|
||||||
(if multi-currencies-p
|
|
||||||
fmt-multiple-currencies
|
|
||||||
fmt-one-currency)))
|
|
||||||
(map fmt-function collector-list)))
|
|
||||||
|
|
||||||
|
|
||||||
(let* ((payables-account (car (op-value sect-acc opt-pay-acc)))
|
|
||||||
(creditors (make-hash-table 23))
|
|
||||||
|
|
||||||
(report-title (op-value gnc:pagename-general
|
|
||||||
gnc:optname-reportname))
|
|
||||||
;; document will be the HTML document that we return.
|
|
||||||
(report-date (gnc:timepair-end-day-time
|
|
||||||
(gnc:date-option-absolute-time
|
|
||||||
(op-value gnc:pagename-general (N_ "To")))))
|
|
||||||
(use-description? (op-value gnc:pagename-general optname-use-description))
|
|
||||||
(interval-vec (list->vector (make-interval-list report-date)))
|
|
||||||
(sort-pred (get-sort-pred
|
|
||||||
(op-value gnc:pagename-general optname-sort-by)
|
|
||||||
(op-value gnc:pagename-general optname-sort-order)))
|
|
||||||
(report-currency (op-value gnc:pagename-general optname-report-currency))
|
|
||||||
(price-source (op-value gnc:pagename-general optname-price-source))
|
|
||||||
(multi-totals-p (op-value gnc:pagename-general optname-multicurrency-totals))
|
|
||||||
(heading-list (make-heading-list))
|
|
||||||
(exchange-fn (gnc:case-exchange-fn price-source report-currency report-date))
|
|
||||||
(total-collector-list (make-collector-list))
|
|
||||||
(table (gnc:make-html-table))
|
|
||||||
(query (gnc:malloc-query))
|
|
||||||
(creditor-list '())
|
|
||||||
(document (gnc:make-html-document)))
|
|
||||||
; (gnc:debug "Payables-account: " payables-account)
|
|
||||||
(gnc:html-document-set-title! document report-title)
|
|
||||||
(gnc:html-table-set-col-headers! table heading-list)
|
|
||||||
|
|
||||||
(if payables-account
|
|
||||||
(begin
|
|
||||||
(setup-query query payables-account report-date)
|
|
||||||
;; get the appropriate splits
|
|
||||||
(let ((splits (gnc:glist->list (gnc:query-get-splits query) <gnc:Split*>)))
|
|
||||||
; (gnc:debug "splits" splits)
|
|
||||||
|
|
||||||
;; build the table
|
|
||||||
(for-each (lambda (split)
|
|
||||||
(update-creditor-hash creditors
|
|
||||||
split
|
|
||||||
interval-vec
|
|
||||||
use-description?))
|
|
||||||
splits)
|
|
||||||
; (gnc:debug "creditors" creditors)
|
|
||||||
;; turn the hash into a list
|
|
||||||
(hash-for-each (lambda (key value)
|
|
||||||
(set! creditor-list
|
|
||||||
(cons (cons key value) creditor-list)))
|
|
||||||
creditors)
|
|
||||||
; (gnc:debug "creditor list" creditor-list)
|
|
||||||
|
|
||||||
(set! creditor-list (sort-list! creditor-list
|
|
||||||
sort-pred))
|
|
||||||
|
|
||||||
;; build the table
|
|
||||||
(for-each (lambda (creditor-list-entry)
|
|
||||||
(let ((monetary-list (convert-to-monetary-list
|
|
||||||
(creditor-get-buckets
|
|
||||||
(cdr creditor-list-entry))
|
|
||||||
(creditor-get-currency
|
|
||||||
(cdr creditor-list-entry)))))
|
|
||||||
(add-to-column-totals total-collector-list monetary-list)
|
|
||||||
(gnc:html-table-append-row!
|
|
||||||
table (cons (car creditor-list-entry) monetary-list))))
|
|
||||||
creditor-list)
|
|
||||||
|
|
||||||
;; add the totals
|
|
||||||
(gnc:html-table-append-row!
|
|
||||||
table
|
|
||||||
(cons (_ "Total") (convert-collectors total-collector-list
|
|
||||||
report-currency
|
|
||||||
exchange-fn
|
|
||||||
multi-totals-p)))
|
|
||||||
|
|
||||||
(gnc:html-document-add-object!
|
|
||||||
document table)))
|
|
||||||
(gnc:html-document-add-object!
|
|
||||||
document
|
|
||||||
(gnc:make-html-text
|
|
||||||
"No Valid Account Selected")))
|
|
||||||
(gnc:free-query query)
|
|
||||||
document))
|
|
||||||
|
|
||||||
;; Here we define the actual report with gnc:define-report
|
;; Here we define the actual report with gnc:define-report
|
||||||
(gnc:define-report
|
(gnc:define-report
|
||||||
@ -621,11 +118,11 @@ totals to report currency")
|
|||||||
;; The name of this report. This will be used, among other things,
|
;; The name of this report. This will be used, among other things,
|
||||||
;; for making its menu item in the main menu. You need to use the
|
;; for making its menu item in the main menu. You need to use the
|
||||||
;; untranslated value here!
|
;; untranslated value here!
|
||||||
'name (N_ "Accounts Payable")
|
'name (N_ "Payable Aging")
|
||||||
|
|
||||||
;; A tip that is used to provide additional information about the
|
;; A tip that is used to provide additional information about the
|
||||||
;; report to the user.
|
;; report to the user.
|
||||||
'menu-tip (N_ "Amount owing, grouped by debtors and age.")
|
'menu-tip (N_ "Amount owed, grouped by creditors and age.")
|
||||||
|
|
||||||
;; A path describing where to put the report in the menu system.
|
;; A path describing where to put the report in the menu system.
|
||||||
;; In this case, it's going under the utility menu.
|
;; In this case, it's going under the utility menu.
|
||||||
|
|||||||
135
src/report/standard-reports/receivables.scm
Normal file
135
src/report/standard-reports/receivables.scm
Normal file
@ -0,0 +1,135 @@
|
|||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; receivables.scm : accounts receivable aging report
|
||||||
|
;;
|
||||||
|
;; By Derek Atkins <warlord@MIT.EDU>
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2 of
|
||||||
|
;; the License, or (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;; GNU General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this program; if not, contact:
|
||||||
|
;;
|
||||||
|
;; Free Software Foundation Voice: +1-617-542-5942
|
||||||
|
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||||
|
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||||
|
;;
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define-module (gnucash report receivables))
|
||||||
|
|
||||||
|
(use-modules (ice-9 slib))
|
||||||
|
(use-modules (gnucash bootstrap))
|
||||||
|
(use-modules (gnucash gnc-module))
|
||||||
|
|
||||||
|
(gnc:module-load "gnucash/report/report-system" 0)
|
||||||
|
|
||||||
|
(use-modules (gnucash report aging))
|
||||||
|
|
||||||
|
(define opt-rec-acc (N_ "Receivables Account"))
|
||||||
|
(define sect-acc (N_ "Accounts"))
|
||||||
|
|
||||||
|
(define (options-generator)
|
||||||
|
(let* ((options (gnc:new-options))
|
||||||
|
(add-option
|
||||||
|
(lambda (new-option)
|
||||||
|
(gnc:register-option options new-option))))
|
||||||
|
|
||||||
|
(add-option
|
||||||
|
(gnc:make-account-list-option
|
||||||
|
sect-acc opt-rec-acc
|
||||||
|
"a" (N_ "Account where receivables are stored.")
|
||||||
|
;; FIXME: Have a global preference for the receivables account??
|
||||||
|
;; default-getter
|
||||||
|
(lambda ()
|
||||||
|
(define (find-first-receivable current-group num-accounts this-account-ind)
|
||||||
|
(if
|
||||||
|
(>= this-account-ind num-accounts)
|
||||||
|
#f
|
||||||
|
(let*
|
||||||
|
((this-account
|
||||||
|
(gnc:group-get-account current-group this-account-ind))
|
||||||
|
(account-type (gw:enum-<gnc:AccountType>-val->sym
|
||||||
|
(gnc:account-get-type this-account) #f)))
|
||||||
|
(begin
|
||||||
|
(gnc:debug "this-account" this-account)
|
||||||
|
(gnc:debug "account-type" account-type)
|
||||||
|
(if (eq? account-type 'receivable)
|
||||||
|
(begin
|
||||||
|
(gnc:debug "this-account selected" this-account)
|
||||||
|
this-account)
|
||||||
|
(find-first-receivable
|
||||||
|
current-group num-accounts (+ this-account-ind 1)))))))
|
||||||
|
|
||||||
|
(let* ((current-group (gnc:get-current-group))
|
||||||
|
(num-accounts (gnc:group-get-num-accounts
|
||||||
|
current-group)))
|
||||||
|
(if (> num-accounts 0)
|
||||||
|
(let ((first-receivable (find-first-receivable
|
||||||
|
current-group
|
||||||
|
num-accounts
|
||||||
|
0)))
|
||||||
|
(gnc:debug "first-receivable" first-receivable)
|
||||||
|
(if first-receivable
|
||||||
|
(list first-receivable)
|
||||||
|
(list (gnc:group-get-account current-group 0))))
|
||||||
|
'())))
|
||||||
|
;; value-validator
|
||||||
|
(lambda (account-list)
|
||||||
|
(let ((first-account) (car account-list))
|
||||||
|
(gnc:debug "account-list" account-list)
|
||||||
|
(if first-account
|
||||||
|
(let ((account-type (gw:enum-<gnc:AccountType>-val->sym
|
||||||
|
(gnc:account-get-type first-account))))
|
||||||
|
(if (eq? 'receivable account-type)
|
||||||
|
|
||||||
|
(cons #t (list first-account))
|
||||||
|
(cons #f (_ "The receivables account must be a receivable account"))))
|
||||||
|
;; FIXME: until we can select a default account I need
|
||||||
|
;; to catch this at the report-writing stage
|
||||||
|
(#t '()))))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(aging-options-generator options)))
|
||||||
|
|
||||||
|
(define (receivables-renderer report-obj)
|
||||||
|
|
||||||
|
(define (get-op section name)
|
||||||
|
(gnc:lookup-option (gnc:report-options report-obj) section name))
|
||||||
|
|
||||||
|
(define (op-value section name)
|
||||||
|
(gnc:option-value (get-op section name)))
|
||||||
|
|
||||||
|
(let* ((receivables-account (car (op-value sect-acc opt-rec-acc))))
|
||||||
|
(aging-renderer report-obj receivables-account #t)))
|
||||||
|
|
||||||
|
;; Here we define the actual report with gnc:define-report
|
||||||
|
(gnc:define-report
|
||||||
|
|
||||||
|
;; The version of this report.
|
||||||
|
'version 1
|
||||||
|
|
||||||
|
;; The name of this report. This will be used, among other things,
|
||||||
|
;; for making its menu item in the main menu. You need to use the
|
||||||
|
;; untranslated value here!
|
||||||
|
'name (N_ "Receivable Aging")
|
||||||
|
|
||||||
|
;; A tip that is used to provide additional information about the
|
||||||
|
;; report to the user.
|
||||||
|
'menu-tip (N_ "Amount owed, grouped by creditors and age.")
|
||||||
|
|
||||||
|
;; A path describing where to put the report in the menu system.
|
||||||
|
;; In this case, it's going under the utility menu.
|
||||||
|
'menu-path (list gnc:menuname-asset-liability)
|
||||||
|
|
||||||
|
;; The options generator function defined above.
|
||||||
|
'options-generator options-generator
|
||||||
|
|
||||||
|
;; The rendering function defined above.
|
||||||
|
'renderer receivables-renderer)
|
||||||
@ -17,10 +17,11 @@
|
|||||||
(use-modules (gnucash report balance-sheet))
|
(use-modules (gnucash report balance-sheet))
|
||||||
(use-modules (gnucash report category-barchart))
|
(use-modules (gnucash report category-barchart))
|
||||||
(use-modules (gnucash report net-barchart))
|
(use-modules (gnucash report net-barchart))
|
||||||
(use-modules (gnucash report payables))
|
|
||||||
(use-modules (gnucash report pnl))
|
(use-modules (gnucash report pnl))
|
||||||
(use-modules (gnucash report portfolio))
|
(use-modules (gnucash report portfolio))
|
||||||
(use-modules (gnucash report price-scatter))
|
(use-modules (gnucash report price-scatter))
|
||||||
|
(use-modules (gnucash report payables))
|
||||||
|
(use-modules (gnucash report receivables))
|
||||||
(use-modules (gnucash report register))
|
(use-modules (gnucash report register))
|
||||||
(use-modules (gnucash report transaction))
|
(use-modules (gnucash report transaction))
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user