diff --git a/src/report/report-system/html-acct-table.scm b/src/report/report-system/html-acct-table.scm
index f6ffec7d9f..cd6a00d202 100644
--- a/src/report/report-system/html-acct-table.scm
+++ b/src/report/report-system/html-acct-table.scm
@@ -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
diff --git a/src/report/report-system/report-system.scm b/src/report/report-system/report-system.scm
index 5c36035399..887e521b58 100644
--- a/src/report/report-system/report-system.scm
+++ b/src/report/report-system/report-system.scm
@@ -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)
diff --git a/src/report/report-system/report-utilities.scm b/src/report/report-system/report-utilities.scm
index 9c753c1710..d84af1f83f 100644
--- a/src/report/report-system/report-utilities.scm
+++ b/src/report/report-system/report-utilities.scm
@@ -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
;; over the period from to .
;; 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 argument
;; may currently be 'entry|'debit-q|'credit-q|'zero-q|'debit|'credit