gnucash maint: [new-aging] new receivable/payable aging reports
Christopher Lam
clam at code.gnucash.org
Sun Oct 27 03:03:28 EDT 2019
Updated via https://github.com/Gnucash/gnucash/commit/0ef11d16 (commit)
from https://github.com/Gnucash/gnucash/commit/6eab852f (commit)
commit 0ef11d16e168450682bb218d0a5fcf42dbeae275
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Oct 27 14:11:13 2019 +0800
[new-aging] new receivable/payable aging reports
diff --git a/gnucash/report/business-reports/CMakeLists.txt b/gnucash/report/business-reports/CMakeLists.txt
index 7d63798c1..f72f12a59 100644
--- a/gnucash/report/business-reports/CMakeLists.txt
+++ b/gnucash/report/business-reports/CMakeLists.txt
@@ -7,6 +7,7 @@ set (business_reports_SCHEME
receipt.scm
invoice.scm
job-report.scm
+ new-aging.scm
owner-report.scm
payables.scm
receivables.scm
diff --git a/gnucash/report/business-reports/business-reports.scm b/gnucash/report/business-reports/business-reports.scm
index 9c331ee57..3191f84ac 100644
--- a/gnucash/report/business-reports/business-reports.scm
+++ b/gnucash/report/business-reports/business-reports.scm
@@ -116,6 +116,7 @@
(use-modules (gnucash report receipt))
(use-modules (gnucash report owner-report))
(use-modules (gnucash report job-report))
+(use-modules (gnucash report new-aging))
(use-modules (gnucash report payables))
(use-modules (gnucash report receivables))
(use-modules (gnucash report customer-summary))
diff --git a/gnucash/report/business-reports/new-aging.scm b/gnucash/report/business-reports/new-aging.scm
new file mode 100644
index 000000000..66d70c1f9
--- /dev/null
+++ b/gnucash/report/business-reports/new-aging.scm
@@ -0,0 +1,377 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; new-aging.scm : accounts payable/receivable aging report
+;;
+;; By Christopher Lam, rewrite and debug
+;; By Derek Atkins <warlord at MIT.EDU> taken from the original...
+;; By Robert Merkel (rgmerk at mira.net)
+;; Copyright (c) 2002, 2003 Derek Atkins <warlord at 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
+;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
+;; Boston, MA 02110-1301, USA gnu at gnu.org
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-module (gnucash report new-aging))
+
+(use-modules (srfi srfi-1))
+(use-modules (srfi srfi-11)) ;let-values
+(use-modules (gnucash utilities))
+(use-modules (gnucash gnc-module))
+(use-modules (gnucash gettext))
+
+(gnc:module-load "gnucash/report/report-system" 0)
+
+(use-modules (gnucash report standard-reports))
+(use-modules (gnucash report business-reports))
+
+(define optname-to-date (N_ "To"))
+(define optname-sort-order (N_ "Sort Order"))
+(define optname-report-currency (N_ "Report's currency"))
+(define optname-price-source (N_ "Price Source"))
+(define optname-show-zeros (N_ "Show zero balance items"))
+(define optname-date-driver (N_ "Due or Post Date"))
+
+(define no-APAR-account (_ "No valid A/Payable or A/Receivable \
+account found. Please ensure valid AP/AR account exists."))
+
+(define empty-APAR-accounts (_ "A/Payable or A/Receivable accounts \
+exist but have no suitable transactions."))
+
+(define num-buckets 6)
+
+(define (setup-query query accounts date)
+ (qof-query-set-book query (gnc-get-current-book))
+ (gnc:query-set-match-non-voids-only! query (gnc-get-current-book))
+ (xaccQueryAddAccountMatch query accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
+ (xaccQueryAddDateMatchTT query #f 0 #t date QOF-QUERY-AND)
+ (qof-query-set-sort-order query (list SPLIT-TRANS TRANS-DATE-POSTED) '() '())
+ (qof-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")
+
+ ;; Use a default report date of 'today'
+ (gnc:option-set-default-value
+ (gnc:lookup-option options gnc:pagename-general optname-to-date)
+ (cons 'relative 'today))
+
+ (add-option
+ (gnc:make-multichoice-option
+ gnc:pagename-general optname-sort-order "ia" (N_ "Sort order.") 'increasing
+ (list
+ (vector 'increasing (N_ "Increasing") (N_ "Alphabetical order"))
+ (vector 'decreasing (N_ "Decreasing") (N_ "Reverse alphabetical order")))))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-general optname-show-zeros "j"
+ (N_ "Show all vendors/customers even if they have a zero balance.")
+ #f))
+
+ (add-option
+ (gnc:make-multichoice-option
+ gnc:pagename-general optname-date-driver "k" (N_ "Leading date.") 'duedate
+ (list
+ ;; Should be using standard label for due date?
+ (vector 'duedate
+ (N_ "Due Date")
+ (N_ "Due date is leading."))
+ ;; Should be using standard label for post date?
+ (vector 'postdate
+ (N_ "Post Date")
+ (N_ "Post date is leading.")))))
+
+ (gnc:options-set-default-section options "General")
+ options))
+
+(define (make-interval-list to-date)
+ (let* ((begindate to-date)
+ (begindate (decdate begindate ThirtyDayDelta))
+ (begindate (decdate begindate ThirtyDayDelta))
+ (begindate (decdate begindate ThirtyDayDelta)))
+ (gnc:make-date-list begindate to-date ThirtyDayDelta)))
+
+;; Have make-list create a stepped list, then add a date in the future
+;; for the "current" bucket
+(define (make-extended-interval-list to-date)
+ (append (make-interval-list to-date)
+ (list +inf.0)))
+
+(define (txn-is-invoice? txn)
+ (eqv? (xaccTransGetTxnType txn) TXN-TYPE-INVOICE))
+
+(define (txn-is-payment? txn)
+ (eqv? (xaccTransGetTxnType txn) TXN-TYPE-PAYMENT))
+
+(define (gnc-owner-equal? a b)
+ (string=? (gncOwnerReturnGUID a) (gncOwnerReturnGUID b)))
+
+(define (split-has-owner? split owner)
+ (let* ((split-owner (split->owner split))
+ (retval (gnc-owner-equal? split-owner owner)))
+ (gncOwnerFree split-owner)
+ retval))
+
+(define (split-from-acct? split acct)
+ (equal? acct (xaccSplitGetAccount split)))
+
+(define (list-split lst fn cmp)
+ (let-values (((list-yes list-no) (partition (lambda (elt) (fn elt cmp)) lst)))
+ (cons list-yes list-no)))
+
+;; simpler version of gnc:owner-from-split. must be gncOwnerFree after
+;; use! see split-has-owner? above...
+(define (split->owner split)
+ (let* ((lot (xaccSplitGetLot (gnc-lot-get-earliest-split (xaccSplitGetLot split))))
+ (owner (gncOwnerNew))
+ (use-lot-owner? (gncOwnerGetOwnerFromLot lot owner)))
+ (unless use-lot-owner?
+ (gncOwnerCopy (gncOwnerGetEndOwner
+ (gncInvoiceGetOwner (gncInvoiceGetInvoiceFromLot lot)))
+ owner))
+ owner))
+
+(define (owner-splits->aging-list splits to-date date-type receivable)
+ (gnc:debug 'processing: (qof-print-date to-date) date-type 'receivable receivable)
+ (for-each gnc:debug splits)
+ (let ((bucket-dates (make-extended-interval-list to-date))
+ (buckets (make-vector num-buckets 0)))
+ (define (addbucket! idx amt)
+ (vector-set! buckets idx (+ amt (vector-ref buckets idx))))
+ (let lp ((splits splits))
+ (cond
+ ((null? splits)
+ (vector->list buckets))
+
+ ;; next split is an invoice posting split. note we don't need
+ ;; to handle invoice payments because these payments will
+ ;; reduce the lot balance automatically.
+ ((txn-is-invoice? (xaccSplitGetParent (car splits)))
+ (let* ((lot (gncInvoiceGetPostedLot
+ (gncInvoiceGetInvoiceFromTxn
+ (xaccSplitGetParent (car splits)))))
+ (invoice (gncInvoiceGetInvoiceFromLot lot))
+ (bal (gnc-lot-get-balance lot))
+ (bal (if receivable bal (- bal)))
+ (date (if (eq? date-type 'postdate)
+ (gncInvoiceGetDatePosted invoice)
+ (gncInvoiceGetDateDue invoice))))
+ (gnc:pk 'next=invoice (car splits) invoice bal)
+ (let loop ((idx 0)
+ (bucket-dates bucket-dates))
+ (gnc:debug idx buckets bal invoice date)
+ (if (< date (car bucket-dates))
+ (addbucket! idx bal)
+ (loop (1+ idx) (cdr bucket-dates))))
+ (gnc:debug '* buckets bal invoice date))
+ (lp (cdr splits)))
+
+ ;; next split is a prepayment
+ ((and (txn-is-payment? (xaccSplitGetParent (car splits)))
+ (null? (gncInvoiceGetInvoiceFromLot (xaccSplitGetLot (car splits)))))
+ (let* ((prepay (xaccSplitGetAmount (car splits)))
+ (prepay (if receivable prepay (- prepay))))
+ (gnc:pk 'next=prepay (car splits) prepay)
+ (addbucket! (1- num-buckets) prepay))
+ (lp (cdr splits)))
+
+ ;; not invoice/prepayment. regular or payment split.
+ (else
+ (gnc:pk 'next=skipped (car splits))
+ (lp (cdr splits)))))))
+
+(define (aging-renderer report-obj receivable)
+ (define (op-value section name)
+ (gnc:option-value
+ (gnc:lookup-option (gnc:report-options report-obj) section name)))
+
+ (define make-heading-list
+ (list ""
+ (_ "Company")
+ (_ "Prepayments")
+ (_ "Current")
+ (_ "0-30 days")
+ (_ "31-60 days")
+ (_ "61-90 days")
+ (_ "91+ days")
+ (_ "Total")))
+
+ (let* ((type (if receivable ACCT-TYPE-RECEIVABLE ACCT-TYPE-PAYABLE))
+ (accounts (filter (lambda (acc) (eqv? (xaccAccountGetType acc) type))
+ (gnc-account-get-descendants-sorted
+ (gnc-get-current-root-account))))
+ (report-title (op-value gnc:pagename-general gnc:optname-reportname))
+ (report-date (gnc:time64-end-day-time
+ (gnc:date-option-absolute-time
+ (op-value gnc:pagename-general optname-to-date))))
+ (sort-order (op-value gnc:pagename-general optname-sort-order))
+ (show-zeros (op-value gnc:pagename-general optname-show-zeros))
+ (date-type (op-value gnc:pagename-general optname-date-driver))
+ (query (qof-query-create-for-splits))
+ (document (gnc:make-html-document)))
+
+ ;; for sorting and delete-duplicates. compare GUIDs
+ (define (ownerGUID<? a b)
+ (string<? (gncOwnerGetGUID a) (gncOwnerGetGUID b)))
+
+ ;; for presentation. compare names.
+ (define (owner<? a b)
+ ((if (eq? sort-order 'increasing) string<? string>?)
+ (gncOwnerGetName a) (gncOwnerGetName b)))
+
+ ;; set default title
+ (gnc:html-document-set-title! document report-title)
+
+ (cond
+ ((null? accounts)
+ (gnc:html-document-add-object!
+ document (gnc:make-html-text no-APAR-account)))
+
+ (else
+ (setup-query query accounts report-date)
+ (let* ((splits (qof-query-run query))
+ (accounts (sort-and-delete-duplicates (map xaccSplitGetAccount splits)
+ gnc:account-path-less-p equal?))
+ (table (gnc:make-html-table)))
+ (qof-query-destroy query)
+
+ ;; loop into each APAR account
+ (let loop ((accounts accounts)
+ (splits (filter
+ (lambda (split)
+ (or (txn-is-invoice? (xaccSplitGetParent split))
+ (txn-is-payment? (xaccSplitGetParent split))))
+ splits)))
+ (cond
+ ((null? accounts)
+ (gnc:html-table-set-col-headers! table make-heading-list)
+ (gnc:html-document-add-object!
+ document (if (null? (gnc:html-table-data table))
+ (gnc:make-html-text empty-APAR-accounts)
+ table)))
+
+ (else
+ (let* ((account (car accounts))
+ (comm (xaccAccountGetCommodity account))
+ (splits-acc-others (list-split splits split-from-acct? account))
+ (acc-splits (car splits-acc-others))
+ (other-acc-splits (cdr splits-acc-others)))
+
+ (gnc:debug 'account account)
+ (gnc:html-table-append-row!
+ table (list (gnc:make-html-table-cell/size
+ 1 (+ 2 num-buckets) (xaccAccountGetName account))))
+
+ (let* ((split-owners (map split->owner acc-splits))
+ (acc-owners (sort (sort-and-delete-duplicates
+ split-owners ownerGUID<? gnc-owner-equal?)
+ owner<?)))
+
+ (gnc:debug 'owners acc-owners)
+
+ ;; loop into each APAR account split
+ (let lp ((acc-owners acc-owners)
+ (acc-splits acc-splits)
+ (acc-totals (make-list (1+ num-buckets) 0)))
+ (cond
+ ((null? acc-owners)
+ (for-each gncOwnerFree split-owners)
+ (gnc:html-table-append-row!
+ table
+ (cons* #f
+ (gnc:make-html-table-cell/markup
+ "total-label-cell" (_ "Total"))
+ (map
+ (lambda (amt)
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" (gnc:make-gnc-monetary comm amt)))
+ acc-totals)))
+ (loop (cdr accounts)
+ other-acc-splits))
+
+ (else
+ (let* ((owner (car acc-owners))
+ (splits-own-others (list-split acc-splits split-has-owner?
+ owner))
+ (owner-splits (car splits-own-others))
+ (other-owner-splits (cdr splits-own-others))
+ (aging (owner-splits->aging-list
+ owner-splits report-date date-type receivable))
+ (aging-total (apply + aging)))
+ (when (or show-zeros (not (every zero? aging)))
+ (gnc:html-table-append-row!
+ table
+ (append
+ (list #f)
+ (cons
+ (gnc:make-html-text
+ (gnc:html-markup-anchor
+ (gnc:owner-anchor-text owner)
+ (gncOwnerGetName owner)))
+ (map
+ (lambda (amt)
+ (gnc:make-html-table-cell/markup
+ "number-cell" (gnc:make-gnc-monetary comm amt)))
+ (reverse aging)))
+ (list
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:make-html-text
+ (gnc:html-markup-anchor
+ (gnc:owner-report-text owner account)
+ (gnc:make-gnc-monetary comm aging-total))))))))
+ (lp (cdr acc-owners)
+ other-owner-splits
+ (map + acc-totals
+ (reverse (cons aging-total aging))))))))))))))))
+ (gnc:report-finished)
+ document))
+
+(define (payable-options-generator)
+ (aging-options-generator (gnc:new-options)))
+
+(define (receivable-options-generator)
+ (aging-options-generator (gnc:new-options)))
+
+(define (payables-renderer report-obj)
+ (aging-renderer report-obj #f))
+
+(define (receivables-renderer report-obj)
+ (aging-renderer report-obj #t))
+
+(gnc:define-report
+ 'version 1
+ 'name (N_ "Payable Aging (beta)")
+ 'report-guid "e57770f2dbca46619d6dac4ac5469b50-new"
+ 'menu-path (list gnc:menuname-experimental)
+ 'options-generator payable-options-generator
+ 'renderer payables-renderer
+ 'in-menu? #t)
+
+(gnc:define-report
+ 'version 1
+ 'name (N_ "Receivable Aging (beta)")
+ 'report-guid "9cf76bed17f14401b8e3e22d0079cb98-new"
+ 'menu-path (list gnc:menuname-experimental)
+ 'options-generator receivable-options-generator
+ 'renderer receivables-renderer
+ 'in-menu? #t)
diff --git a/po/POTFILES.in b/po/POTFILES.in
index 709bb76bc..b2165e163 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -418,6 +418,7 @@ gnucash/report/business-reports/business-reports.scm
gnucash/report/business-reports/customer-summary.scm
gnucash/report/business-reports/invoice.scm
gnucash/report/business-reports/job-report.scm
+gnucash/report/business-reports/new-aging.scm
gnucash/report/business-reports/owner-report.scm
gnucash/report/business-reports/payables.scm
gnucash/report/business-reports/receipt.eguile.scm
Summary of changes:
gnucash/report/business-reports/CMakeLists.txt | 1 +
.../report/business-reports/business-reports.scm | 1 +
gnucash/report/business-reports/new-aging.scm | 377 +++++++++++++++++++++
po/POTFILES.in | 1 +
4 files changed, 380 insertions(+)
create mode 100644 gnucash/report/business-reports/new-aging.scm
More information about the gnucash-changes
mailing list