mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Reports: Speed up the report infrastructure. Patch by Mike Alexander.
One set of changes speeds up the three functions in report-utilities.scm: gnc:account-get-comm-balance-interval gnc:accountlist-get-comm-balance-interval gnc:accountlist-get-comm-balance-at-date These can all be implemented as calls to gnc:account-get-trans-type-balance-interval (with a minor change to it to ignore the type parameter if it is #f) and it is much faster since it does a single query instead of a loop over an account list. The other set of changes is in gnc:html-acct-table-add-accounts! in html-acct-table.scm. This functions starts off by building a hash table of account balances it cares about. The code to do this did a recursive loop over the relevant accounts. I changed it to do a query to find the splits in the accounts it cares about and build the hash table from them. This speeds it up by a couple of orders of magnitude. git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@17988 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Charles Day
parent
2d2e2d5b0e
commit
c3b86442c0
@ -638,74 +638,71 @@
|
||||
|
||||
;; the following function was adapted from html-utilities.scm
|
||||
;;
|
||||
;;
|
||||
;; there's got to be a prettier way to do this. maybe even make two
|
||||
;; of these. The balance-mode is only used by trial-balance.scm. so
|
||||
;; make two versions of this animal, one that cares about balance-mode
|
||||
;; one that doesn't. then check for a balance-mode !'post-closing and
|
||||
;; call the right one. later.
|
||||
(define (get-balance-nosub-mode account start-date end-date)
|
||||
(let* ((post-closing-bal
|
||||
(if start-date
|
||||
(gnc:account-get-comm-balance-interval
|
||||
account start-date end-date #f)
|
||||
(gnc:account-get-comm-balance-at-date
|
||||
account end-date #f)))
|
||||
(closing (lambda(a)
|
||||
(gnc:account-get-trans-type-balance-interval
|
||||
(list account) closing-pattern
|
||||
start-date end-date)
|
||||
)
|
||||
)
|
||||
(adjusting (lambda(a)
|
||||
(gnc:account-get-trans-type-balance-interval
|
||||
(list account) adjusting-pattern
|
||||
start-date end-date)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(cond
|
||||
((equal? balance-mode 'post-closing)
|
||||
post-closing-bal)
|
||||
|
||||
((equal? balance-mode 'pre-closing)
|
||||
(let* ((closing-amt (closing account))
|
||||
)
|
||||
(post-closing-bal 'minusmerge closing-amt #f))
|
||||
post-closing-bal)
|
||||
|
||||
((equal? balance-mode 'pre-adjusting)
|
||||
(let* ((closing-amt (closing account))
|
||||
(adjusting-amt (adjusting account))
|
||||
))
|
||||
(post-closing-bal 'minusmerge closing-amt #f)
|
||||
(post-closing-bal 'minusmerge adjusting-amt #f)
|
||||
post-closing-bal)
|
||||
(else (begin (display "you fail it")
|
||||
(newline))))
|
||||
|
||||
)
|
||||
)
|
||||
|
||||
;; helper to calculate the balances for all required accounts
|
||||
(define (calculate-balances accts start-date end-date get-balance-fn)
|
||||
(define (calculate-balances-helper accts start-date end-date acct-balances)
|
||||
(if (not (null? accts))
|
||||
(begin
|
||||
;; using the existing function that cares about balance-mode
|
||||
;; maybe this should get replaces at some point.
|
||||
(hash-set! acct-balances (gncAccountGetGUID (car accts))
|
||||
(get-balance-fn (car accts) start-date end-date))
|
||||
(calculate-balances-helper (cdr accts) start-date end-date acct-balances)
|
||||
)
|
||||
;; using the existing function that cares about balance-mode
|
||||
;; maybe this should get replaces at some point.
|
||||
(hash-set! acct-balances (gncAccountGetGUID (car accts))
|
||||
(get-balance-fn (car accts) start-date end-date))
|
||||
(calculate-balances-helper (cdr accts) start-date end-date acct-balances)
|
||||
)
|
||||
acct-balances)
|
||||
)
|
||||
|
||||
(calculate-balances-helper accts start-date end-date
|
||||
(make-hash-table 23))
|
||||
)
|
||||
|
||||
(define (calculate-balances-simple accts start-date end-date hash-table)
|
||||
(define (merge-splits splits subtract?)
|
||||
(for-each
|
||||
(lambda (split)
|
||||
(let* ((acct (xaccSplitGetAccount split))
|
||||
(guid (gncAccountGetGUID acct))
|
||||
(acct-comm (xaccAccountGetCommodity acct))
|
||||
(shares (xaccSplitGetAmount split))
|
||||
(hash (hash-ref hash-table guid)))
|
||||
; (gnc:debug "Merging split for " (xaccAccountGetName acct) " for "
|
||||
; (gnc-commodity-numeric->string acct-comm shares)
|
||||
; " into hash entry " hash)
|
||||
(if (not hash)
|
||||
(begin (set! hash (gnc:make-commodity-collector))
|
||||
(hash-set! hash-table guid hash)))
|
||||
(hash 'add acct-comm (if subtract?
|
||||
(gnc-numeric-neg shares)
|
||||
shares))))
|
||||
splits))
|
||||
|
||||
(merge-splits (gnc:account-get-trans-type-splits-interval
|
||||
accts #f start-date end-date)
|
||||
#f)
|
||||
(cond
|
||||
((equal? balance-mode 'post-closing) #t)
|
||||
|
||||
((equal? balance-mode 'pre-closing)
|
||||
(merge-splits (gnc:account-get-trans-type-splits-interval
|
||||
accts closing-pattern start-date end-date)
|
||||
#t))
|
||||
|
||||
((equal? balance-mode 'pre-adjusting)
|
||||
(merge-splits (gnc:account-get-trans-type-splits-interval
|
||||
accts closing-pattern start-date end-date)
|
||||
#t)
|
||||
(merge-splits (gnc:account-get-trans-type-splits-interval
|
||||
accts adjusting-pattern start-date end-date)
|
||||
#t))
|
||||
(else (begin (display "you fail it")
|
||||
(newline))))
|
||||
hash-table
|
||||
)
|
||||
|
||||
(if get-balance-fn
|
||||
(calculate-balances-helper accts start-date end-date
|
||||
(make-hash-table 23))
|
||||
(calculate-balances-simple accts start-date end-date
|
||||
(make-hash-table 23))
|
||||
)
|
||||
)
|
||||
|
||||
(define (traverse-accounts! accts acct-depth logi-depth new-balances)
|
||||
|
||||
@ -900,7 +897,8 @@
|
||||
) ;; end of definition of traverse-accounts!
|
||||
|
||||
;; do it
|
||||
(traverse-accounts! toplvl-accts 0 0 (calculate-balances accounts start-date end-date (or get-balance-fn get-balance-nosub-mode)))
|
||||
(traverse-accounts! toplvl-accts 0 0
|
||||
(calculate-balances accounts start-date end-date get-balance-fn))
|
||||
|
||||
;; set the column-header colspan
|
||||
(if gnc:colspans-are-working-right
|
||||
|
||||
@ -663,6 +663,7 @@
|
||||
(export gnc-commodity-collector-allzero?)
|
||||
(export gnc:account-get-trans-type-balance-interval)
|
||||
(export gnc:account-get-pos-trans-total-interval)
|
||||
(export gnc:account-get-trans-type-splits-interval)
|
||||
(export gnc:double-col)
|
||||
(export gnc:budget-get-start-date)
|
||||
(export gnc:budget-account-get-net)
|
||||
|
||||
@ -624,39 +624,22 @@
|
||||
;; the version which returns a commodity-collector
|
||||
(define (gnc:account-get-comm-balance-interval
|
||||
account from to include-children?)
|
||||
;; Since this function calculates a balance difference it has to
|
||||
;; subtract the balance of the previous day's end (from-date)
|
||||
;; instead of the plain date.
|
||||
(let ((this-collector (gnc:account-get-comm-balance-at-date
|
||||
account to include-children?)))
|
||||
(gnc-commodity-collector-minusmerge
|
||||
this-collector
|
||||
(gnc:account-get-comm-balance-at-date
|
||||
account
|
||||
(gnc:timepair-end-day-time (gnc:timepair-previous-day from))
|
||||
include-children?))
|
||||
this-collector))
|
||||
(let ((account-list (if include-children?
|
||||
(let ((sub-accts (gnc-account-get-descendants-sorted account)))
|
||||
(if sub-accts
|
||||
(append (list account) sub-accts)
|
||||
(list account)))
|
||||
(list account))))
|
||||
(gnc:account-get-trans-type-balance-interval account-list #f from to)))
|
||||
|
||||
;; This calculates the increase in the balance(s) of all accounts in
|
||||
;; <accountlist> over the period from <from-date> to <to-date>.
|
||||
;; Returns a commodity collector.
|
||||
(define (gnc:accountlist-get-comm-balance-interval accountlist from to)
|
||||
(let ((collector (gnc:make-commodity-collector)))
|
||||
(for-each (lambda (account)
|
||||
(gnc-commodity-collector-merge
|
||||
collector (gnc:account-get-comm-balance-interval
|
||||
account from to #f)))
|
||||
accountlist)
|
||||
collector))
|
||||
(gnc:account-get-trans-type-balance-interval accountlist #f from to))
|
||||
|
||||
(define (gnc:accountlist-get-comm-balance-at-date accountlist date)
|
||||
(let ((collector (gnc:make-commodity-collector)))
|
||||
(for-each (lambda (account)
|
||||
(gnc-commodity-collector-merge
|
||||
collector (gnc:account-get-comm-balance-at-date
|
||||
account date #f)))
|
||||
accountlist)
|
||||
collector))
|
||||
(gnc:account-get-trans-type-balance-interval accountlist #f #f date))
|
||||
|
||||
;; utility function - ensure that a query matches only non-voids. Destructive.
|
||||
(define (gnc:query-set-match-non-voids-only! query book)
|
||||
@ -720,40 +703,21 @@
|
||||
|
||||
;; Sums up any splits of a certain type affecting a set of accounts.
|
||||
;; the type is an alist '((str "match me") (cased #f) (regexp #f))
|
||||
;; If type is #f, sums all splits in the interval
|
||||
(define (gnc:account-get-trans-type-balance-interval
|
||||
account-list type start-date-tp end-date-tp)
|
||||
(let* ((query (qof-query-create-for-splits))
|
||||
(splits #f)
|
||||
(get-val (lambda (alist key)
|
||||
(let ((lst (assoc-ref alist key)))
|
||||
(if lst (car lst) lst))))
|
||||
(matchstr (get-val type 'str))
|
||||
(case-sens (if (get-val type 'cased) #t #f))
|
||||
(regexp (if (get-val type 'regexp) #t #f))
|
||||
(total (gnc:make-commodity-collector))
|
||||
)
|
||||
(qof-query-set-book query (gnc-get-current-book))
|
||||
(gnc:query-set-match-non-voids-only! query (gnc-get-current-book))
|
||||
(xaccQueryAddAccountMatch query account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
|
||||
(xaccQueryAddDateMatchTS
|
||||
query
|
||||
(and start-date-tp #t) start-date-tp
|
||||
(and end-date-tp #t) end-date-tp QOF-QUERY-AND)
|
||||
(xaccQueryAddDescriptionMatch
|
||||
query matchstr case-sens regexp QOF-QUERY-AND)
|
||||
|
||||
(set! splits (qof-query-run query))
|
||||
(let* ((total (gnc:make-commodity-collector)))
|
||||
(map (lambda (split)
|
||||
(let* ((shares (xaccSplitGetAmount split))
|
||||
(acct-comm (xaccAccountGetCommodity
|
||||
(xaccSplitGetAccount split)))
|
||||
)
|
||||
(gnc-commodity-collector-add total acct-comm shares)
|
||||
)
|
||||
)
|
||||
splits
|
||||
(let* ((shares (xaccSplitGetAmount split))
|
||||
(acct-comm (xaccAccountGetCommodity
|
||||
(xaccSplitGetAccount split)))
|
||||
)
|
||||
(gnc-commodity-collector-add total acct-comm shares)
|
||||
)
|
||||
)
|
||||
(gnc:account-get-trans-type-splits-interval
|
||||
account-list type start-date-tp end-date-tp)
|
||||
)
|
||||
(qof-query-destroy query)
|
||||
total
|
||||
)
|
||||
)
|
||||
@ -820,6 +784,35 @@
|
||||
)
|
||||
)
|
||||
|
||||
;; Return the splits that match an account list, date range, and (optionally) type
|
||||
;; where type is defined as an alist '((str "match me") (cased #f) (regexp #f))
|
||||
(define (gnc:account-get-trans-type-splits-interval
|
||||
account-list type start-date-tp end-date-tp)
|
||||
(let* ((query (qof-query-create-for-splits))
|
||||
(splits #f)
|
||||
(get-val (lambda (alist key)
|
||||
(let ((lst (assoc-ref alist key)))
|
||||
(if lst (car lst) lst))))
|
||||
(matchstr (get-val type 'str))
|
||||
(case-sens (if (get-val type 'cased) #t #f))
|
||||
(regexp (if (get-val type 'regexp) #t #f))
|
||||
)
|
||||
(qof-query-set-book query (gnc-get-current-book))
|
||||
(gnc:query-set-match-non-voids-only! query (gnc-get-current-book))
|
||||
(xaccQueryAddAccountMatch query account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
|
||||
(xaccQueryAddDateMatchTS
|
||||
query
|
||||
(and start-date-tp #t) start-date-tp
|
||||
(and end-date-tp #t) end-date-tp QOF-QUERY-AND)
|
||||
(if type (xaccQueryAddDescriptionMatch
|
||||
query matchstr case-sens regexp QOF-QUERY-AND))
|
||||
|
||||
(set! splits (qof-query-run query))
|
||||
(qof-query-destroy query)
|
||||
splits
|
||||
)
|
||||
)
|
||||
|
||||
;; utility to assist with double-column balance tables
|
||||
;; a request is made with the <req> argument
|
||||
;; <req> may currently be 'entry|'debit-q|'credit-q|'zero-q|'debit|'credit
|
||||
|
||||
Loading…
Reference in New Issue
Block a user