IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2026-09-03 20:53:02 -05:00
Code Issues Packages Projects Releases Wiki Activity

Improve the QIF txn matcher (#336211)

Browse Source 
Don't run it when we have no accounts or empty accounts.
Cache the account list early on.
Patch by Charles Day
BP


git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@16873 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Derek Atkins
2008-01-20 17:36:00 +00:00
parent 1db95753b7
commit 41c195d3f2
1 changed files with 156 additions and 125 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/import-export/qif-import/qif-merge-groups.scm
+156 -125
View File
@@ -1,156 +1,187 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; qif-merge-groups.scm ;;; qif-merge-groups.scm
;;; eliminate duplicate xtns in a new (imported) account group ;;; eliminate duplicate xtns in a new (imported) account group
;;; ;;;
;;; Copyright 2001 Bill Gribble <grib@billgribble.com> ;;; Copyright 2001 Bill Gribble <grib@billgribble.com>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:account-tree-get-transactions root) (define (gnc:account-tree-get-transactions root)
(let ((query (qof-query-create-for-splits)) (let ((accounts (gnc-account-get-descendants-sorted root)))
(xtns #f)) (if (null? accounts)
'()
(let ((query (qof-query-create-for-splits))
(xtns #f))
(qof-query-set-book query (gnc-account-get-book root)) (qof-query-set-book query (gnc-account-get-book root))
;; we want to find all transactions with every split inside the ;; we want to find all transactions with every split inside the
;; account group. ;; account group.
(xaccQueryAddAccountMatch query (xaccQueryAddAccountMatch query accounts
(gnc-account-get-descendants-sorted root) QOF-GUID-MATCH-ANY QOF-QUERY-AND)
QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(set! xtns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ALL)) (set! xtns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ALL))
;; lose the query ;; lose the query
(qof-query-destroy query) (qof-query-destroy query)
xtns)) xtns))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:account-tree-find-duplicates ;; gnc:account-tree-find-duplicates
;; detect redundant splits/xtns from 'new' and return ;;
;; them in a list. ;; This procedure compares two account trees, given by old-root
;; and new-root, and returns a list of splits/transactions in
;; old-root that may be duplicates.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:account-tree-find-duplicates old-root new-root window) (define (gnc:account-tree-find-duplicates old-root new-root window)
;; get all the transactions in the new group, then iterate over them
;; trying to find matches in the new group. If there are matches,
;; push the matches onto a list.
(let* ((new-xtns (gnc:account-tree-get-transactions new-root))
(progress-dialog '())
(work-to-do (length new-xtns))
(work-done 0)
(matches '()))
(if (> work-to-do 100)
(begin
(set! progress-dialog (gnc-progress-dialog-new window #f))
(gnc-progress-dialog-set-title progress-dialog (_ "Progress"))
(gnc-progress-dialog-set-heading progress-dialog
(_ "Finding duplicate transactions..."))))
;; for each transaction in the new account tree, build a query that could ;; Given a list of accounts, this predicate returns true if any
;; match possibly similar transactions. ;; of those accounts are involved in a transaction.
(for-each (define (has-any-xtns? acctlist)
(lambda (xtn) (if (null? acctlist)
(let ((query (qof-query-create-for-splits))) #f
(set! work-done (+ 1 work-done)) (let ((splits (xaccAccountGetSplitList (car acctlist))))
(if (not (null? progress-dialog)) (if (null? splits)
(begin (has-any-xtns? (cdr acctlist))
(gnc-progress-dialog-set-value #t))))
progress-dialog (/ work-done work-to-do))
(gnc-progress-dialog-update progress-dialog)))
(qof-query-set-book query (gnc-account-get-book old-root)) (let ((old-accounts (gnc-account-get-descendants-sorted old-root)))
(if (has-any-xtns? old-accounts)
;; Get all the transactions in the new tree, then iterate over them
;; trying to find matches in the old tree. If there are matches,
;; push the matches onto a list.
(let* ((new-xtns (gnc:account-tree-get-transactions new-root))
(progress-dialog '())
(work-to-do (length new-xtns))
(work-done 0)
(matches '()))
;; first, we want to find only transactions from the old group. ;; Use a progress dialog if this might take a while.
(xaccQueryAddAccountMatch query (if (> work-to-do 100)
(gnc-account-get-descendants-sorted old-root) (begin
QOF-GUID-MATCH-ANY QOF-QUERY-AND) (set! progress-dialog (gnc-progress-dialog-new window #f))
(gnc-progress-dialog-set-title progress-dialog (_ "Progress"))
;; the date should be close to the same.. +/- a week. (gnc-progress-dialog-set-heading progress-dialog
(let ((date (gnc-transaction-get-date-posted xtn))) (_ "Finding duplicate transactions..."))))
(xaccQueryAddDateMatchTS
query #t (decdate date WeekDelta) #t (incdate date WeekDelta) ;; For each transaction in the new account tree, build a query
QOF-QUERY-AND)) ;; that matches possibly duplicate transactions in the old tree.
(for-each
;; for each split in the transaction, add a term to match the (lambda (xtn)
;; properties of one split (let ((query (qof-query-create-for-splits)))
(let ((q-splits (qof-query-create-for-splits))) (set! work-done (+ 1 work-done))
(for-each (if (not (null? progress-dialog))
(lambda (split) (begin
(let ((sq (qof-query-create-for-splits))) (gnc-progress-dialog-set-value progress-dialog
(qof-query-set-book sq (gnc-account-get-book old-root)) (/ work-done work-to-do))
(gnc-progress-dialog-update progress-dialog)))
;; we want to match the account in the old account
;; tree that has the same name as an account in the (qof-query-set-book query (gnc-account-get-book old-root))
;; new account tree. If there's not one (new
;; account), the match will be NULL and we know the ;; First, we only want to find only transactions
;; query won't find anything. optimize this later. ;; from accounts in the old tree.
(xaccQueryAddSingleAccountMatch (xaccQueryAddAccountMatch query
sq old-accounts
(gnc-account-lookup-by-full-name QOF-GUID-MATCH-ANY QOF-QUERY-AND)
old-root (gnc-account-get-full-name
(xaccSplitGetAccount split))) ;; The date should be close to the same.. +/- a week.
QOF-QUERY-AND) (let ((date (gnc-transaction-get-date-posted xtn)))
(xaccQueryAddDateMatchTS query #t
;; we want the value for the split to match the value (decdate date WeekDelta) #t
;; the old-root split. We should really check for (incdate date WeekDelta)
;; fuzziness. QOF-QUERY-AND))
(xaccQueryAddValueMatch
sq (xaccSplitGetValue split) ;; For each split in the transaction, add a term
QOF-NUMERIC-MATCH-ANY QOF-COMPARE-EQUAL ;; to match the properties of one split.
QOF-QUERY-AND) (let ((q-splits (qof-query-create-for-splits)))
(for-each
;; now merge into the split query. Reminder: q-splits (lambda (split)
;; is set up to match any split that matches any split (let ((sq (qof-query-create-for-splits)))
;; in the current xtn; every split in an old transaction (qof-query-set-book sq (gnc-account-get-book old-root))
;; must pass that filter.
(let ((q-new (qof-query-merge q-splits sq QOF-QUERY-OR))) ;; We want to match the account in the old tree that
(qof-query-destroy q-splits) ;; has the same name as an account in the new tree.
(qof-query-destroy sq) ;; If there's not one (indicating a new account),
(set! q-splits q-new)))) ;; the match will be NULL and the query won't find
(xaccTransGetSplitList xtn)) ;; anything. Optimize this later.
(xaccQueryAddSingleAccountMatch
;; now q-splits will match any split that is the same as one sq
;; split in the old-root xtn. Merge it in. (gnc-account-lookup-by-full-name old-root
(let ((q-new (qof-query-merge query q-splits QOF-QUERY-AND))) (gnc-account-get-full-name
(qof-query-destroy query) (xaccSplitGetAccount split)))
(qof-query-destroy q-splits) QOF-QUERY-AND)
(set! query q-new)))
;; We want the value of the split in the new tree
;; now that we have built a query, get transactions in the old ;; to match the the value of the split in the old
;; account tree that matches it. ;; tree. We should really check for fuzziness.
(let ((old-xtns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ALL))) (xaccQueryAddValueMatch sq
(set! old-xtns (map (xaccSplitGetValue split)
(lambda (elt) QOF-NUMERIC-MATCH-ANY
(cons elt #f)) old-xtns)) QOF-COMPARE-EQUAL
QOF-QUERY-AND)
;; if anything matched the query, push it onto the matches list
;; along with the transaction ;; Now merge into the split query. Reminder: q-splits
(if (not (null? old-xtns)) ;; is set up to match any split that matches any split
(set! matches (cons (cons xtn old-xtns) matches)))) ;; in the new transaction; every split in an old
(qof-query-destroy query))) ;; transaction must pass that filter.
new-xtns) (let ((q-new (qof-query-merge q-splits
sq
;; get rid of the progress dialog QOF-QUERY-OR)))
(if (not (null? progress-dialog)) (qof-query-destroy q-splits)
(gnc-progress-dialog-destroy progress-dialog)) (qof-query-destroy sq)
(set! q-splits q-new))))
(xaccTransGetSplitList xtn))
;; Now q-splits will match any split that is the same as one
;; split in the old-root transaction. Merge it in.
(let ((q-new (qof-query-merge query
q-splits
QOF-QUERY-AND)))
(qof-query-destroy query)
(qof-query-destroy q-splits)
(set! query q-new)))
;; Now that we have built a query, get transactions in the old
;; account tree that match it.
(let ((old-xtns (xaccQueryGetTransactions query
QUERY-TXN-MATCH-ALL)))
(set! old-xtns (map
(lambda (elt)
(cons elt #f)) old-xtns))
;; If anything matched the query, push it onto the matches
;; list along with the transaction.
(if (not (null? old-xtns))
(set! matches (cons (cons xtn old-xtns) matches))))
(qof-query-destroy query)))
new-xtns)
;; Get rid of the progress dialog.
(if (not (null? progress-dialog))
(gnc-progress-dialog-destroy progress-dialog))
;; Return the matches.
matches)
;; Since there are either no accounts or no transactions in the old
;; tree, duplicate checking is unnecessary. Return an empty list.
'())))
;; return the matches
matches))
(define (gnc:prune-matching-transactions match-list) (define (gnc:prune-matching-transactions match-list)
(for-each (for-each
(lambda (match) (lambda (match)
(let ((new-xtn (car match)) (let ((new-xtn (car match))
(matches (cdr match)) (matches (cdr match))
(do-delete #f)) (do-delete #f))
(for-each (for-each
(lambda (old) (lambda (old)
(if (cdr old) (if (cdr old)
(set! do-delete #t))) (set! do-delete #t)))
matches) matches)
(if do-delete (if do-delete
(begin (begin
(xaccTransBeginEdit new-xtn) (xaccTransBeginEdit new-xtn)
(xaccTransDestroy new-xtn) (xaccTransDestroy new-xtn)
(xaccTransCommitEdit new-xtn))))) (xaccTransCommitEdit new-xtn)))))