diff --git a/src/report/standard-reports/Makefile.am b/src/report/standard-reports/Makefile.am index f0155db033..801bdfa94c 100644 --- a/src/report/standard-reports/Makefile.am +++ b/src/report/standard-reports/Makefile.am @@ -21,6 +21,7 @@ gncscmmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report/ gncscmmod_DATA = \ account-piecharts.scm \ account-summary.scm \ + aging.scm \ average-balance.scm \ balance-sheet.scm \ category-barchart.scm \ @@ -29,6 +30,7 @@ gncscmmod_DATA = \ pnl.scm \ portfolio.scm \ price-scatter.scm \ + receivables.scm \ register.scm \ standard-reports.scm \ transaction.scm diff --git a/src/report/standard-reports/aging.scm b/src/report/standard-reports/aging.scm new file mode 100644 index 0000000000..acffafc585 --- /dev/null +++ b/src/report/standard-reports/aging.scm @@ -0,0 +1,559 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; aging.scm : accounts payable/receivable aging report utilities +;; +;; By Derek Atkins 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))))) + (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) + (stringlist 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: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) diff --git a/src/report/standard-reports/payables.scm b/src/report/standard-reports/payables.scm index b0102a17ff..addcf7ef38 100644 --- a/src/report/standard-reports/payables.scm +++ b/src/report/standard-reports/payables.scm @@ -1,7 +1,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; payables.scm : accounts payable report +;; payables.scm : accounts payable aging report ;; -;; By Robert Merkel (rgmerk@mira.net) +;; By Derek Atkins ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -25,255 +25,15 @@ (define-module (gnucash report payables)) (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)) -(require 'hash-table) -(require 'record) - (gnc:module-load "gnucash/report/report-system" 0) +(use-modules (gnucash report aging)) + (define opt-pay-acc (N_ "Payables Account")) (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) (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) (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-account-list-option sect-acc opt-pay-acc @@ -349,268 +96,18 @@ more than one currency. This report is not designed to cope with this possibili (#t '())))) #f)) - (add-option - (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))) + (aging-options-generator options))) (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))))) - (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) - (stringlist 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: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)) + (let* ((payables-account (car (op-value sect-acc opt-pay-acc)))) + (aging-renderer report-obj payables-account #f))) ;; Here we define the actual report with 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, ;; for making its menu item in the main menu. You need to use the ;; untranslated value here! - 'name (N_ "Accounts Payable") + 'name (N_ "Payable Aging") ;; A tip that is used to provide additional information about the ;; 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. ;; In this case, it's going under the utility menu. diff --git a/src/report/standard-reports/receivables.scm b/src/report/standard-reports/receivables.scm new file mode 100644 index 0000000000..0c98644a9e --- /dev/null +++ b/src/report/standard-reports/receivables.scm @@ -0,0 +1,135 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; receivables.scm : accounts receivable aging report +;; +;; By Derek Atkins +;; +;; 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--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--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) diff --git a/src/report/standard-reports/standard-reports.scm b/src/report/standard-reports/standard-reports.scm index e4148ecb53..fd9d1e613a 100644 --- a/src/report/standard-reports/standard-reports.scm +++ b/src/report/standard-reports/standard-reports.scm @@ -17,10 +17,11 @@ (use-modules (gnucash report balance-sheet)) (use-modules (gnucash report category-barchart)) (use-modules (gnucash report net-barchart)) -(use-modules (gnucash report payables)) (use-modules (gnucash report pnl)) (use-modules (gnucash report portfolio)) (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 transaction))