mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Merge Chris Lam's cleanup-report-utilities into maint.
This commit is contained in:
John Ralls
commit
f8a9be2c7f
@ -20,16 +20,6 @@
|
||||
;; Boston, MA 02110-1301, USA gnu@gnu.org
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
(define (gnc-commodity-collector-contains-commodity? collector commodity)
|
||||
(let ((ret #f))
|
||||
(gnc-commodity-collector-map
|
||||
collector
|
||||
(lambda (comm amt)
|
||||
(set! ret (or ret (gnc-commodity-equiv comm commodity)))))
|
||||
ret
|
||||
))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Functions to get splits with interesting data from accounts.
|
||||
|
||||
@ -104,6 +94,8 @@
|
||||
|
||||
;; Helper for warnings below.
|
||||
(define (gnc-commodity-numeric->string commodity numeric)
|
||||
(issue-deprecation-warning "gnc-commodity-numeric->string deprecated. \
|
||||
construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary commodity numeric)))
|
||||
|
||||
@ -167,13 +159,6 @@
|
||||
value-amount share-amount))
|
||||
#f)))
|
||||
|
||||
;;(warn "gnc:get-commodity-totalavg-prices: value "
|
||||
;; (gnc-commodity-numeric->string
|
||||
;;(first foreignlist) (second foreignlist))
|
||||
;; " bought shares "
|
||||
;; (gnc-commodity-numeric->string
|
||||
;;price-commodity (third foreignlist)))
|
||||
|
||||
;; Try EURO exchange if necessary
|
||||
(if (and foreignlist
|
||||
(not (gnc-commodity-equiv (first foreignlist)
|
||||
@ -195,14 +180,17 @@
|
||||
(begin
|
||||
(warn "gnc:get-commodity-totalavg-prices: "
|
||||
"Sorry, currency exchange not yet implemented:"
|
||||
(gnc-commodity-numeric->string
|
||||
(first foreignlist) (second foreignlist))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
(first foreignlist) (second foreignlist)))
|
||||
" (buying "
|
||||
(gnc-commodity-numeric->string
|
||||
price-commodity (third foreignlist))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
price-commodity (third foreignlist)))
|
||||
") =? "
|
||||
(gnc-commodity-numeric->string
|
||||
report-currency (gnc-numeric-zero)))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
report-currency (gnc-numeric-zero))))
|
||||
(gnc-numeric-zero))
|
||||
(begin
|
||||
(set! total-foreign (gnc-numeric-add total-foreign
|
||||
@ -282,13 +270,6 @@
|
||||
(list transaction-comm
|
||||
value-amount share-amount))))
|
||||
|
||||
;;(warn "get-commodity-inst-prices: value "
|
||||
;; (gnc-commodity-numeric->string
|
||||
;; (first foreignlist) (second foreignlist))
|
||||
;; " bought shares "
|
||||
;;(gnc-commodity-numeric->string
|
||||
;; price-commodity (third foreignlist)))
|
||||
|
||||
;; Try EURO exchange if necessary
|
||||
(if (not (gnc-commodity-equiv (first foreignlist)
|
||||
report-currency))
|
||||
@ -308,14 +289,17 @@
|
||||
(begin
|
||||
(warn "get-commodity-inst-prices: "
|
||||
"Sorry, currency exchange not yet implemented:"
|
||||
(gnc-commodity-numeric->string
|
||||
(first foreignlist) (second foreignlist))
|
||||
" (buying "
|
||||
(gnc-commodity-numeric->string
|
||||
price-commodity (third foreignlist))
|
||||
") =? "
|
||||
(gnc-commodity-numeric->string
|
||||
report-currency (gnc-numeric-zero)))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
(first foreignlist) (second foreignlist)))
|
||||
" (buying "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
price-commodity (third foreignlist)))
|
||||
") =? "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
report-currency (gnc-numeric-zero))))
|
||||
(gnc-numeric-zero))
|
||||
(if (not (zero? (third foreignlist)))
|
||||
(gnc-numeric-div
|
||||
@ -398,8 +382,7 @@
|
||||
(let ((price
|
||||
(gnc:pricelist-price-find-nearest
|
||||
plist date)))
|
||||
(if price
|
||||
price
|
||||
(or price
|
||||
(gnc-numeric-zero)))
|
||||
(gnc-numeric-zero))))
|
||||
|
||||
@ -498,14 +481,14 @@
|
||||
;; resolve the exchange rate to this currency.
|
||||
(warn "gnc:resolve-unknown-comm:"
|
||||
"can't calculate rate for "
|
||||
(gnc-commodity-value->string
|
||||
(list (car pair) ((caadr pair) 'total #f)))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary (car pair) ((caadr pair) 'total #f)))
|
||||
" = "
|
||||
(gnc-commodity-value->string
|
||||
(list (car otherlist) ((cdadr pair) 'total #f)))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary (car otherlist) ((cdadr pair) 'total #f)))
|
||||
" to "
|
||||
(gnc-commodity-value->string
|
||||
(list report-commodity (gnc-numeric-zero))))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary report-commodity (gnc-numeric-zero))))
|
||||
(if (and pair-a pair-b)
|
||||
;; If both currencies are found then something
|
||||
;; went wrong inside
|
||||
@ -513,11 +496,11 @@
|
||||
;; better thing to do in this case.
|
||||
(warn "gnc:resolve-unknown-comm:"
|
||||
"Oops - exchange rate ambiguity error: "
|
||||
(gnc-commodity-value->string
|
||||
(list (car pair) ((caadr pair) 'total #f)))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary (car pair) ((caadr pair) 'total #f)))
|
||||
" = "
|
||||
(gnc-commodity-value->string
|
||||
(list (car otherlist)
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary (car otherlist)
|
||||
((cdadr pair) 'total #f))))
|
||||
(let
|
||||
;; Usual case: one of pair-{a,b} was found
|
||||
@ -531,23 +514,12 @@
|
||||
(list (car pair)
|
||||
(make-newrate (caadr pair)
|
||||
(cdadr pair) pair-a)))))
|
||||
;; (warn "created new rate: "
|
||||
;; (gnc-commodity-value->string (list (car
|
||||
;; newrate) ((caadr newrate) 'total #f))) "
|
||||
;; = " (gnc-commodity-value->string (list
|
||||
;; report-commodity ((cdadr newrate) 'total
|
||||
;; #f))))
|
||||
(set! reportlist (cons newrate reportlist))))))
|
||||
;; Huh, the report-currency showed up on the wrong side
|
||||
;; -- we will just add it to the reportlist on the
|
||||
;; right side.
|
||||
(let ((newrate (list (car otherlist)
|
||||
(cons (cdadr pair) (caadr pair)))))
|
||||
;; (warn "created new rate: "
|
||||
;; (gnc-commodity-value->string (list (car newrate)
|
||||
;; ((caadr newrate) 'total #f))) " = "
|
||||
;; (gnc-commodity-value->string (list
|
||||
;; report-commodity ((cdadr newrate) 'total #f))))
|
||||
(set! reportlist (cons newrate reportlist)))))
|
||||
(cadr otherlist))))
|
||||
sumlist)
|
||||
@ -785,9 +757,8 @@
|
||||
;; #f if the commodities don't match. Therefore, if you use this
|
||||
;; function in a mixed commodity context, stuff will probably crash.
|
||||
(define (gnc:exchange-if-same foreign domestic)
|
||||
(if (gnc-commodity-equiv (gnc:gnc-monetary-commodity foreign) domestic)
|
||||
foreign
|
||||
#f))
|
||||
(and (gnc-commodity-equiv (gnc:gnc-monetary-commodity foreign) domestic)
|
||||
foreign))
|
||||
|
||||
;; This one returns the ready-to-use function for calculation of the
|
||||
;; exchange rates. The returned function takes a <gnc-monetary> and
|
||||
@ -798,43 +769,41 @@
|
||||
(lambda (foreign domestic)
|
||||
(gnc:debug "foreign: " (gnc:monetary->string foreign))
|
||||
(gnc:debug "domestic: " (gnc-commodity-get-printname domestic))
|
||||
(if foreign
|
||||
(or (gnc:exchange-by-euro foreign domestic #f)
|
||||
(gnc:exchange-if-same foreign domestic)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(let ((pair (assoc (gnc:gnc-monetary-commodity foreign)
|
||||
exchangelist))
|
||||
(foreign-amount (gnc:gnc-monetary-amount foreign)))
|
||||
(if (or (not pair)
|
||||
(gnc-numeric-zero-p foreign-amount))
|
||||
(gnc-numeric-zero)
|
||||
(gnc-numeric-mul foreign-amount
|
||||
(cadr pair)
|
||||
(gnc-commodity-get-fraction domestic)
|
||||
GNC-RND-ROUND)))))
|
||||
#f))))
|
||||
(and foreign
|
||||
(or (gnc:exchange-by-euro foreign domestic #f)
|
||||
(gnc:exchange-if-same foreign domestic)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(let ((pair (assoc (gnc:gnc-monetary-commodity foreign)
|
||||
exchangelist))
|
||||
(foreign-amount (gnc:gnc-monetary-amount foreign)))
|
||||
(if (or (not pair)
|
||||
(gnc-numeric-zero-p foreign-amount))
|
||||
(gnc-numeric-zero)
|
||||
(gnc-numeric-mul foreign-amount
|
||||
(cadr pair)
|
||||
(gnc-commodity-get-fraction domestic)
|
||||
GNC-RND-ROUND)))))))))
|
||||
|
||||
;; Helper for the gnc:exchange-by-pricalist* below. Exchange the
|
||||
;; <gnc:monetary> 'foreign' into the <gnc:commodity*> 'domestic' by
|
||||
;; the <gnc:numeric> 'price-value'. Returns a <gnc:monetary>.
|
||||
(define (gnc:exchange-by-pricevalue-helper
|
||||
foreign domestic price-value)
|
||||
(if (gnc:gnc-monetary? foreign)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(if price-value
|
||||
(gnc-numeric-mul (gnc:gnc-monetary-amount foreign)
|
||||
price-value
|
||||
(gnc-commodity-get-fraction domestic)
|
||||
GNC-RND-ROUND)
|
||||
(begin
|
||||
(warn "gnc:exchange-by-pricevalue-helper: No price found for "
|
||||
(gnc:monetary->string foreign) " into "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary domestic (gnc-numeric-zero))))
|
||||
(gnc-numeric-zero))))
|
||||
#f))
|
||||
(and (gnc:gnc-monetary? foreign)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(if price-value
|
||||
(gnc-numeric-mul (gnc:gnc-monetary-amount foreign)
|
||||
price-value
|
||||
(gnc-commodity-get-fraction domestic)
|
||||
GNC-RND-ROUND)
|
||||
(begin
|
||||
(warn "gnc:exchange-by-pricevalue-helper: No price found for "
|
||||
(gnc:monetary->string foreign) " into "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary domestic (gnc-numeric-zero))))
|
||||
(gnc-numeric-zero))))))
|
||||
|
||||
;; Helper for gnc:exchange-by-pricedb-* below. 'price' gets tested for
|
||||
;; #f here, and gets unref'd here too. Exchange the <gnc:monetary>
|
||||
@ -842,24 +811,23 @@
|
||||
;; 'price'. Returns a <gnc:monetary>.
|
||||
(define (gnc:exchange-by-pricedb-helper
|
||||
foreign domestic price)
|
||||
(if (gnc:gnc-monetary? foreign)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(if price
|
||||
(let ((result
|
||||
(gnc-numeric-mul (gnc:gnc-monetary-amount foreign)
|
||||
(gnc-price-get-value price)
|
||||
(gnc-commodity-get-fraction domestic)
|
||||
GNC-RND-ROUND)))
|
||||
(gnc-price-unref price)
|
||||
result)
|
||||
(begin
|
||||
(warn "gnc:exchange-by-pricedb-helper: No price found for "
|
||||
(gnc:monetary->string foreign) " into "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary domestic (gnc-numeric-zero))))
|
||||
(gnc-numeric-zero))))
|
||||
#f))
|
||||
(and (gnc:gnc-monetary? foreign)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(if price
|
||||
(let ((result
|
||||
(gnc-numeric-mul (gnc:gnc-monetary-amount foreign)
|
||||
(gnc-price-get-value price)
|
||||
(gnc-commodity-get-fraction domestic)
|
||||
GNC-RND-ROUND)))
|
||||
(gnc-price-unref price)
|
||||
result)
|
||||
(begin
|
||||
(warn "gnc:exchange-by-pricedb-helper: No price found for "
|
||||
(gnc:monetary->string foreign) " into "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary domestic (gnc-numeric-zero))))
|
||||
(gnc-numeric-zero))))))
|
||||
|
||||
;; This is another ready-to-use function for calculation of exchange
|
||||
;; rates. (Note that this is already the function itself. It doesn't
|
||||
@ -870,17 +838,17 @@
|
||||
;; returns a <gnc-monetary>.
|
||||
(define (gnc:exchange-by-pricedb-latest
|
||||
foreign domestic)
|
||||
(if (and (record? foreign) (gnc:gnc-monetary? foreign))
|
||||
(or (gnc:exchange-by-euro foreign domestic #f)
|
||||
(gnc:exchange-if-same foreign domestic)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(gnc-pricedb-convert-balance-latest-price
|
||||
(gnc-pricedb-get-db (gnc-get-current-book))
|
||||
(gnc:gnc-monetary-amount foreign)
|
||||
(gnc:gnc-monetary-commodity foreign)
|
||||
domestic)))
|
||||
#f))
|
||||
(and (record? foreign)
|
||||
(gnc:gnc-monetary? foreign)
|
||||
(or (gnc:exchange-by-euro foreign domestic #f)
|
||||
(gnc:exchange-if-same foreign domestic)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(gnc-pricedb-convert-balance-latest-price
|
||||
(gnc-pricedb-get-db (gnc-get-current-book))
|
||||
(gnc:gnc-monetary-amount foreign)
|
||||
(gnc:gnc-monetary-commodity foreign)
|
||||
domestic)))))
|
||||
|
||||
;; Yet another ready-to-use function for calculation of exchange
|
||||
;; rates. (Note that this is already the function itself. It doesn't
|
||||
@ -892,18 +860,18 @@
|
||||
;; <gnc-monetary>.
|
||||
(define (gnc:exchange-by-pricedb-nearest
|
||||
foreign domestic date)
|
||||
(if (and (record? foreign) (gnc:gnc-monetary? foreign)
|
||||
date)
|
||||
(or (gnc:exchange-by-euro foreign domestic date)
|
||||
(gnc:exchange-if-same foreign domestic)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(gnc-pricedb-convert-balance-nearest-price-t64
|
||||
(gnc-pricedb-get-db (gnc-get-current-book))
|
||||
(gnc:gnc-monetary-amount foreign)
|
||||
(gnc:gnc-monetary-commodity foreign)
|
||||
domestic (time64CanonicalDayTime date))))
|
||||
#f))
|
||||
(and (record? foreign)
|
||||
(gnc:gnc-monetary? foreign)
|
||||
date
|
||||
(or (gnc:exchange-by-euro foreign domestic date)
|
||||
(gnc:exchange-if-same foreign domestic)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(gnc-pricedb-convert-balance-nearest-price-t64
|
||||
(gnc-pricedb-get-db (gnc-get-current-book))
|
||||
(gnc:gnc-monetary-amount foreign)
|
||||
(gnc:gnc-monetary-commodity foreign)
|
||||
domestic (time64CanonicalDayTime date))))))
|
||||
|
||||
;; Exchange by the nearest price from pricelist. This function takes
|
||||
;; the <gnc-monetary> 'foreign' amount, the <gnc:commodity*>
|
||||
@ -913,26 +881,19 @@
|
||||
;; function returns a <gnc-monetary>.
|
||||
(define (gnc:exchange-by-pricealist-nearest
|
||||
pricealist foreign domestic date)
|
||||
(begin
|
||||
(gnc:debug "foreign " (gnc:monetary->string foreign))
|
||||
(gnc:debug "domestic " (gnc-commodity-get-printname domestic))
|
||||
(gnc:debug "pricealist " pricealist)
|
||||
|
||||
(if (and (record? foreign) (gnc:gnc-monetary? foreign)
|
||||
date)
|
||||
(or (gnc:exchange-by-euro foreign domestic date)
|
||||
(gnc:exchange-if-same foreign domestic)
|
||||
(if (not (null? pricealist))
|
||||
(gnc:debug "foreign " (gnc:monetary->string foreign))
|
||||
(gnc:debug "domestic " (gnc-commodity-get-printname domestic))
|
||||
(gnc:debug "pricealist " pricealist)
|
||||
(and (record? foreign)
|
||||
(gnc:gnc-monetary? foreign)
|
||||
date
|
||||
(or (gnc:exchange-by-euro foreign domestic date)
|
||||
(gnc:exchange-if-same foreign domestic)
|
||||
(and (pair? pricealist)
|
||||
(gnc:exchange-by-pricevalue-helper
|
||||
foreign domestic
|
||||
(gnc:pricealist-lookup-nearest-in-time
|
||||
pricealist (gnc:gnc-monetary-commodity foreign) date))
|
||||
#f))
|
||||
#f)))
|
||||
|
||||
|
||||
|
||||
|
||||
pricealist (gnc:gnc-monetary-commodity foreign) date))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Choosing exchange functions made easy -- get the right function by
|
||||
@ -1036,63 +997,58 @@
|
||||
;; Returns a <gnc-monetary> with the domestic commodity and its
|
||||
;; corresponding balance. If the foreign balance is #f, it returns #f.
|
||||
(define (gnc:sum-collector-commodity foreign domestic exchange-fn)
|
||||
(cond ((and foreign exchange-fn)
|
||||
(let ((balance (gnc:make-commodity-collector)))
|
||||
(foreign
|
||||
'format
|
||||
(lambda (curr val)
|
||||
(if (gnc-commodity-equiv domestic curr)
|
||||
(balance 'add domestic val)
|
||||
(balance 'add domestic
|
||||
(gnc:gnc-monetary-amount
|
||||
;; BUG?: this bombs if the exchange-fn
|
||||
;; returns #f instead of an actual
|
||||
;; <gnc:monetary>. Better to just return #f.
|
||||
(exchange-fn (gnc:make-gnc-monetary curr val)
|
||||
domestic)))))
|
||||
#f)
|
||||
(balance 'getmonetary domestic #f)))
|
||||
(else #f)))
|
||||
(and foreign
|
||||
exchange-fn
|
||||
(let ((balance (gnc:make-commodity-collector)))
|
||||
(foreign
|
||||
'format
|
||||
(lambda (curr val)
|
||||
(if (gnc-commodity-equiv domestic curr)
|
||||
(balance 'add domestic val)
|
||||
(balance 'add domestic
|
||||
(gnc:gnc-monetary-amount
|
||||
;; BUG?: this bombs if the exchange-fn
|
||||
;; returns #f instead of an actual
|
||||
;; <gnc:monetary>. Better to just return #f.
|
||||
(exchange-fn (gnc:make-gnc-monetary curr val)
|
||||
domestic)))))
|
||||
#f)
|
||||
(balance 'getmonetary domestic #f))))
|
||||
|
||||
;; As above, but adds only the commodities of other stocks and
|
||||
;; mutual-funds. Returns a commodity-collector, (not a <gnc:monetary>)
|
||||
;; which (still) may have several different commodities in it -- if
|
||||
;; there have been different *currencies*, not only stocks.
|
||||
(define (gnc:sum-collector-stocks foreign domestic exchange-fn)
|
||||
(if foreign
|
||||
(let ((balance (gnc:make-commodity-collector)))
|
||||
(foreign
|
||||
'format
|
||||
(lambda (curr val)
|
||||
(if (gnc-commodity-equiv domestic curr)
|
||||
(balance 'add domestic val)
|
||||
(if (gnc-commodity-is-currency curr)
|
||||
(balance 'add curr val)
|
||||
(balance 'add domestic
|
||||
(gnc:gnc-monetary-amount
|
||||
(exchange-fn (gnc:make-gnc-monetary curr val)
|
||||
domestic))))))
|
||||
#f)
|
||||
balance)
|
||||
#f))
|
||||
(and foreign
|
||||
(let ((balance (gnc:make-commodity-collector)))
|
||||
(foreign
|
||||
'format
|
||||
(lambda (curr val)
|
||||
(if (gnc-commodity-equiv domestic curr)
|
||||
(balance 'add domestic val)
|
||||
(if (gnc-commodity-is-currency curr)
|
||||
(balance 'add curr val)
|
||||
(balance 'add domestic
|
||||
(gnc:gnc-monetary-amount
|
||||
(exchange-fn (gnc:make-gnc-monetary curr val)
|
||||
domestic))))))
|
||||
#f)
|
||||
balance)))
|
||||
|
||||
;; Returns the number of commodities in a commodity-collector.
|
||||
;; (If this were implemented as a record, I would be able to
|
||||
;; just (length ...) the alist, but....)
|
||||
(define (gnc-commodity-collector-commodity-count collector)
|
||||
(let ((commodities 0))
|
||||
(gnc-commodity-collector-map
|
||||
collector
|
||||
(lambda (comm amt)
|
||||
(set! commodities (+ commodities 1))))
|
||||
commodities
|
||||
))
|
||||
(length (collector 'format (lambda (comm amt) comm) #f)))
|
||||
|
||||
(define (gnc-commodity-collector-contains-commodity? collector commodity)
|
||||
(member commodity
|
||||
(collector 'format (lambda (comm amt) comm) #f)
|
||||
gnc-commodity-equiv))
|
||||
|
||||
(define (gnc:uniform-commodity? amt report-commodity)
|
||||
;; function to see if the commodity-collector amt
|
||||
;; contains any foreign commodities
|
||||
(let ((elts (gnc-commodity-collector-commodity-count amt)))
|
||||
(or (equal? elts 0)
|
||||
(and (equal? elts 1)
|
||||
(or (zero? elts)
|
||||
(and (= elts 1)
|
||||
(gnc-commodity-collector-contains-commodity?
|
||||
amt report-commodity)))))
|
||||
|
||||
@ -675,9 +675,6 @@
|
||||
(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)))
|
||||
@ -735,13 +732,12 @@
|
||||
;; ( acct . balance ) cells
|
||||
(define (get-balance acct-balances acct)
|
||||
(let ((this-collector (gnc:make-commodity-collector)))
|
||||
(gnc-commodity-collector-merge
|
||||
this-collector
|
||||
(this-collector
|
||||
'merge
|
||||
(or (hash-ref acct-balances (gncAccountGetGUID acct))
|
||||
;; return a zero commodity collector
|
||||
(gnc:make-commodity-collector)
|
||||
)
|
||||
)
|
||||
(gnc:make-commodity-collector))
|
||||
#f)
|
||||
this-collector
|
||||
)
|
||||
)
|
||||
@ -757,9 +753,9 @@
|
||||
(let ((this-collector (gnc:make-commodity-collector)))
|
||||
;; get the balance of the parent account and stick it on the collector
|
||||
;; that nice shiny *NEW* collector!!
|
||||
(gnc-commodity-collector-merge this-collector (get-balance acct-balances account))
|
||||
(this-collector 'merge (get-balance acct-balances account) #f)
|
||||
(for-each
|
||||
(lambda (x) (if x (gnc-commodity-collector-merge this-collector x)))
|
||||
(lambda (x) (if x (this-collector 'merge x #f)))
|
||||
(gnc:account-map-descendants
|
||||
(lambda (a)
|
||||
(get-balance acct-balances a ))
|
||||
@ -1146,8 +1142,8 @@
|
||||
;; readable.
|
||||
(let* ((table (gnc:make-html-table))
|
||||
)
|
||||
(gnc-commodity-collector-map
|
||||
amount
|
||||
(amount
|
||||
'format
|
||||
(lambda (curr val)
|
||||
(let ((bal (gnc:make-gnc-monetary curr val)))
|
||||
(gnc:html-table-append-row!
|
||||
@ -1165,7 +1161,8 @@
|
||||
"number-cell" (exchange-fn bal report-commodity))
|
||||
)
|
||||
)
|
||||
)))
|
||||
))
|
||||
#f)
|
||||
(gnc:html-table-set-style! table "table" 'attribute(list "style" "width:100%; max-width:20em") 'attribute (list "cellpadding" "0"))
|
||||
table))
|
||||
|
||||
|
||||
@ -281,18 +281,15 @@
|
||||
;; commodity
|
||||
(commodity-row-helper!
|
||||
my-name #f
|
||||
(if balance
|
||||
(gnc-commodity-collector-assoc
|
||||
balance report-commodity reverse-balance?)
|
||||
#f)
|
||||
(and balance
|
||||
(balance 'getmonetary report-commodity reverse-balance?))
|
||||
main-row-style)
|
||||
;; Special case for stock-accounts: then the foreign commodity
|
||||
;; gets displayed in this line rather then the following lines
|
||||
;; (loop below). Is also used if is-stock-account? is true.
|
||||
(let ((my-balance
|
||||
(if balance
|
||||
(gnc-commodity-collector-assoc
|
||||
balance my-commodity reverse-balance?) #f)))
|
||||
(let ((my-balance
|
||||
(and balance
|
||||
(balance 'getmonetary my-commodity reverse-balance?))))
|
||||
(set! already-printed my-commodity)
|
||||
(commodity-row-helper!
|
||||
my-name
|
||||
@ -304,8 +301,8 @@
|
||||
;; balance and its corresponding value in the
|
||||
;; report-currency. One row for each non-report-currency.
|
||||
(if (and balance (not is-stock-account?))
|
||||
(gnc-commodity-collector-map
|
||||
balance
|
||||
(balance
|
||||
'format
|
||||
(lambda (curr val)
|
||||
(if (or (gnc-commodity-equiv curr report-commodity)
|
||||
(and already-printed
|
||||
@ -323,7 +320,7 @@
|
||||
bal
|
||||
(exchange-fn bal report-commodity)
|
||||
other-rows-style))))
|
||||
))))
|
||||
#f))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@ -466,8 +463,7 @@
|
||||
(let ((this-collector (my-get-balance-nosub account)))
|
||||
(for-each
|
||||
(lambda (x) (if x
|
||||
(gnc-commodity-collector-merge
|
||||
this-collector x )))
|
||||
(this-collector 'merge x #f)))
|
||||
(gnc:account-map-descendants
|
||||
(lambda (a)
|
||||
;; Important: Calculate the balance if and only if the
|
||||
@ -639,7 +635,7 @@
|
||||
subaccounts my-get-balance
|
||||
gnc-reverse-balance)))
|
||||
(if thisbalance
|
||||
(gnc-commodity-collector-merge subbalance thisbalance))
|
||||
(subbalance 'merge thisbalance #f))
|
||||
subbalance)
|
||||
heading-style
|
||||
#t #f)))))
|
||||
|
||||
@ -20,27 +20,26 @@
|
||||
(use-modules (srfi srfi-13))
|
||||
|
||||
(define (list-ref-safe list elt)
|
||||
(if (> (length list) elt)
|
||||
(list-ref list elt)
|
||||
#f))
|
||||
(and (> (length list) elt)
|
||||
(list-ref list elt)))
|
||||
|
||||
(define (list-set-safe! l elt val)
|
||||
(if (and (list? l) (> (length l) elt))
|
||||
(unless (list? l)
|
||||
(set! l '()))
|
||||
(if (> (length l) elt)
|
||||
(list-set! l elt val)
|
||||
(let ((filler (list val)))
|
||||
(if (not (list? l))
|
||||
(set! l '()))
|
||||
(let loop ((i (length l)))
|
||||
(if (< i elt)
|
||||
(begin
|
||||
(set! filler (cons #f filler))
|
||||
(loop (+ 1 i)))))
|
||||
(set! l (append! l filler))))
|
||||
(let loop ((filler (list val))
|
||||
(i (length l)))
|
||||
(if (< i elt)
|
||||
(loop (cons #f filler) (1+ i))
|
||||
(set! l (append! l filler)))))
|
||||
l)
|
||||
|
||||
;; pair is a list of one gnc:commodity and one gnc:numeric
|
||||
;; value. Deprecated -- use <gnc-monetary> instead.
|
||||
(define (gnc-commodity-value->string pair)
|
||||
(issue-deprecation-warning "gnc-commodity-value->string deprecated. \
|
||||
construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
(xaccPrintAmount
|
||||
(cadr pair) (gnc-commodity-print-info (car pair) #t)))
|
||||
|
||||
@ -145,10 +144,8 @@
|
||||
|
||||
;; Get all children of this list of accounts.
|
||||
(define (gnc:acccounts-get-all-subaccounts accountlist)
|
||||
(append-map
|
||||
(lambda (a)
|
||||
(gnc-account-get-descendants-sorted a))
|
||||
accountlist))
|
||||
(append-map gnc-account-get-descendants-sorted
|
||||
accountlist))
|
||||
|
||||
;;; Here's a statistics collector... Collects max, min, total, and makes
|
||||
;;; it easy to get at the mean.
|
||||
@ -247,21 +244,13 @@
|
||||
;; This is a collector of values -- works similar to the stats-collector but
|
||||
;; has much less overhead. It is used by the currency-collector (see below).
|
||||
(define (gnc:make-value-collector)
|
||||
(let ;;; values
|
||||
((value 0))
|
||||
(lambda (action amount) ;;; Dispatch function
|
||||
(let ((value 0))
|
||||
(lambda (action amount)
|
||||
(case action
|
||||
((add) (if (number? amount)
|
||||
(set! value (+ amount value))))
|
||||
((add) (if (number? amount)
|
||||
(set! value (+ amount value))))
|
||||
((total) value)
|
||||
(else (gnc:warn "bad value-collector action: " action))))))
|
||||
;; Bah. Let's get back to normal data types -- this procedure thingy
|
||||
;; from above makes every code almost unreadable. First step: replace
|
||||
;; all 'action function calls by the normal functions below.
|
||||
(define (gnc:value-collector-add collector amount)
|
||||
(collector 'add amount))
|
||||
(define (gnc:value-collector-total collector)
|
||||
(collector 'total #f))
|
||||
|
||||
;; A commodity collector. This is intended to handle multiple
|
||||
;; currencies' amounts. The amounts are accumulated via 'add, the
|
||||
@ -320,7 +309,7 @@
|
||||
;; and add it to the alist
|
||||
(set! commoditylist (cons pair commoditylist))))
|
||||
;; add the value
|
||||
(gnc:value-collector-add (cadr pair) rvalue)))
|
||||
((cadr pair) 'add rvalue)))
|
||||
|
||||
;; helper function to walk an association list, adding each
|
||||
;; (commodity -> collector) pair to our list at the appropriate
|
||||
@ -329,14 +318,14 @@
|
||||
(cond ((null? clist) '())
|
||||
(else (add-commodity-value
|
||||
(caar clist)
|
||||
(gnc:value-collector-total (cadar clist)))
|
||||
((cadar clist) 'total #f))
|
||||
(add-commodity-clist (cdr clist)))))
|
||||
|
||||
(define (minus-commodity-clist clist)
|
||||
(cond ((null? clist) '())
|
||||
(else (add-commodity-value
|
||||
(caar clist)
|
||||
(- (gnc:value-collector-total (cadar clist))))
|
||||
(- ((cadar clist) 'total #f)))
|
||||
(minus-commodity-clist (cdr clist)))))
|
||||
|
||||
;; helper function walk the association list doing a callback on
|
||||
@ -344,44 +333,32 @@
|
||||
(define (process-commodity-list fn clist)
|
||||
(map
|
||||
(lambda (pair) (fn (car pair)
|
||||
(gnc:value-collector-total (cadr pair))))
|
||||
((cadr pair) 'total #f)))
|
||||
clist))
|
||||
|
||||
;; helper function which is given a commodity and returns, if
|
||||
;; existing, a list (gnc:commodity gnc:numeric). If the second
|
||||
;; argument was #t, the sign gets reversed.
|
||||
;; existing, a list (gnc:commodity gnc:numeric).
|
||||
(define (getpair c sign?)
|
||||
(let ((pair (assoc c commoditylist)))
|
||||
(cons c (cons
|
||||
(if (not pair)
|
||||
(gnc-numeric-zero)
|
||||
(if sign?
|
||||
(gnc-numeric-neg
|
||||
(gnc:value-collector-total (cadr pair)))
|
||||
(gnc:value-collector-total (cadr pair))))
|
||||
'()))))
|
||||
(let* ((pair (assoc c commoditylist))
|
||||
(total (and pair ((cadr pair) 'total #f))))
|
||||
(list c (if pair (if sign? (- total) total) 0))))
|
||||
|
||||
;; helper function which is given a commodity and returns, if
|
||||
;; existing, a <gnc:monetary> value. If the second argument was
|
||||
;; #t, the sign gets reversed.
|
||||
;; existing, a <gnc:monetary> value.
|
||||
(define (getmonetary c sign?)
|
||||
(let ((pair (assoc c commoditylist)))
|
||||
(let* ((pair (assoc c commoditylist))
|
||||
(total (and pair ((cadr pair) 'total #f))))
|
||||
(gnc:make-gnc-monetary
|
||||
c (if (not pair)
|
||||
(gnc-numeric-zero)
|
||||
(if sign?
|
||||
(gnc-numeric-neg
|
||||
(gnc:value-collector-total (cadr pair)))
|
||||
(gnc:value-collector-total (cadr pair)))))))
|
||||
c (if pair (if sign? (- total) total) 0))))
|
||||
|
||||
;; Dispatch function
|
||||
(lambda (action commodity amount)
|
||||
(case action
|
||||
((add) (add-commodity-value commodity amount))
|
||||
((merge) (add-commodity-clist
|
||||
(gnc-commodity-collector-list commodity)))
|
||||
((merge) (add-commodity-clist
|
||||
(commodity 'list #f #f)))
|
||||
((minusmerge) (minus-commodity-clist
|
||||
(gnc-commodity-collector-list commodity)))
|
||||
(commodity 'list #f #f)))
|
||||
((format) (process-commodity-list commodity commoditylist))
|
||||
((reset) (set! commoditylist '()))
|
||||
((getpair) (getpair commodity amount))
|
||||
@ -390,49 +367,20 @@
|
||||
(else (gnc:warn "bad commodity-collector action: " action))))))
|
||||
|
||||
(define (gnc:commodity-collector-get-negated collector)
|
||||
(let
|
||||
((negated (gnc:make-commodity-collector)))
|
||||
(let ((negated (gnc:make-commodity-collector)))
|
||||
(negated 'minusmerge collector #f)
|
||||
negated))
|
||||
|
||||
(define (gnc:commodity-collectorlist-get-merged collectorlist)
|
||||
(let
|
||||
((merged (gnc:make-commodity-collector)))
|
||||
(let ((merged (gnc:make-commodity-collector)))
|
||||
(for-each (lambda (collector) (merged 'merge collector #f)) collectorlist)
|
||||
merged))
|
||||
|
||||
;; Bah. Let's get back to normal data types -- this procedure thingy
|
||||
;; from above makes every code almost unreadable. First step: replace
|
||||
;; all 'action function calls by the normal functions below.
|
||||
|
||||
;; CAS: ugh. Having two usages is even *more* confusing, so let's
|
||||
;; please settle on one or the other. What's Step 2? How 'bout
|
||||
;; documenting the new functions?
|
||||
(define (gnc-commodity-collector-add collector commodity amount)
|
||||
(collector 'add commodity amount))
|
||||
(define (gnc-commodity-collector-merge collector other-collector)
|
||||
(collector 'merge other-collector #f))
|
||||
(define (gnc-commodity-collector-minusmerge collector other-collector)
|
||||
(collector 'minusmerge other-collector #f))
|
||||
(define (gnc-commodity-collector-map collector function)
|
||||
(collector 'format function #f))
|
||||
(define (gnc-commodity-collector-assoc collector commodity sign?)
|
||||
(collector 'getmonetary commodity sign?))
|
||||
(define (gnc-commodity-collector-assoc-pair collector commodity sign?)
|
||||
(collector 'getpair commodity sign?))
|
||||
(define (gnc-commodity-collector-list collector)
|
||||
(collector 'list #f #f))
|
||||
|
||||
;; Returns zero if all entries in this collector are zero.
|
||||
(define (gnc-commodity-collector-allzero? collector)
|
||||
(let ((result #t))
|
||||
(gnc-commodity-collector-map
|
||||
collector
|
||||
(lambda (commodity amount)
|
||||
(if (not (gnc-numeric-zero-p amount))
|
||||
(set! result #f))))
|
||||
result))
|
||||
|
||||
(every zero?
|
||||
(map gnc:gnc-monetary-amount
|
||||
(collector 'format gnc:make-gnc-monetary #f))))
|
||||
|
||||
;; get the account balance at the specified date. if include-children?
|
||||
;; is true, the balances of all children (not just direct children)
|
||||
@ -440,8 +388,7 @@
|
||||
(define (gnc:account-get-balance-at-date account date include-children?)
|
||||
(let ((collector (gnc:account-get-comm-balance-at-date
|
||||
account date include-children?)))
|
||||
(cadr (gnc-commodity-collector-assoc-pair
|
||||
collector (xaccAccountGetCommodity account) #f))))
|
||||
(cadr (collector 'getpair (xaccAccountGetCommodity account) #f))))
|
||||
|
||||
;; This works similar as above but returns a commodity-collector,
|
||||
;; thus takes care of children accounts with different currencies.
|
||||
@ -457,7 +404,7 @@
|
||||
(if include-children?
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(gnc-commodity-collector-merge balance-collector x))
|
||||
(balance-collector 'merge x #f))
|
||||
(gnc:account-map-descendants
|
||||
(lambda (child)
|
||||
(gnc:account-get-comm-balance-at-date child date #f))
|
||||
@ -477,9 +424,9 @@
|
||||
(qof-query-destroy query)
|
||||
|
||||
(if (and splits (not (null? splits)))
|
||||
(gnc-commodity-collector-add balance-collector
|
||||
(xaccAccountGetCommodity account)
|
||||
(xaccSplitGetBalance (car splits))))
|
||||
(balance-collector 'add
|
||||
(xaccAccountGetCommodity account)
|
||||
(xaccSplitGetBalance (car splits))))
|
||||
balance-collector))
|
||||
|
||||
;; Calculate the increase in the balance of the account in terms of
|
||||
@ -496,7 +443,7 @@
|
||||
(if include-children?
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(gnc-commodity-collector-merge value-collector x))
|
||||
(value-collector 'merge x #f))
|
||||
(gnc:account-map-descendants
|
||||
(lambda (d)
|
||||
(gnc:account-get-comm-value-interval d start-date end-date #f))
|
||||
@ -543,10 +490,10 @@
|
||||
(let ((collector (gnc:make-commodity-collector)))
|
||||
(for-each
|
||||
(lambda (acct)
|
||||
((if (reverse-balance-fn acct)
|
||||
gnc-commodity-collector-minusmerge
|
||||
gnc-commodity-collector-merge)
|
||||
collector (get-balance-fn acct)))
|
||||
(collector
|
||||
(if (reverse-balance-fn acct) 'minusmerge 'merge)
|
||||
(get-balance-fn acct)
|
||||
#f))
|
||||
accounts)
|
||||
collector))
|
||||
|
||||
@ -599,19 +546,14 @@
|
||||
(define (gnc:account-get-balance-interval account from to include-children?)
|
||||
(let ((collector (gnc:account-get-comm-balance-interval
|
||||
account from to include-children?)))
|
||||
(cadr (gnc-commodity-collector-assoc-pair
|
||||
collector (xaccAccountGetCommodity account) #f))))
|
||||
(cadr (collector 'getpair (xaccAccountGetCommodity account) #f))))
|
||||
|
||||
;; the version which returns a commodity-collector
|
||||
(define (gnc:account-get-comm-balance-interval
|
||||
account from to include-children?)
|
||||
(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)))
|
||||
(define (gnc:account-get-comm-balance-interval account from to include-children?)
|
||||
(let ((sub-accts (gnc-account-get-descendants-sorted account)))
|
||||
(gnc:account-get-trans-type-balance-interval
|
||||
(cons account (or (and include-children? sub-accts) '()))
|
||||
#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>.
|
||||
@ -685,10 +627,7 @@
|
||||
|
||||
;; function to count the total number of splits to be iterated
|
||||
(define (gnc:accounts-count-splits accounts)
|
||||
(if (not (null? accounts))
|
||||
(+ (length (xaccAccountGetSplitList (car accounts)))
|
||||
(gnc:accounts-count-splits (cdr accounts)))
|
||||
0))
|
||||
(apply + (map length (map xaccAccountGetSplitList accounts))))
|
||||
|
||||
;; 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))
|
||||
@ -702,105 +641,48 @@
|
||||
(xaccSplitGetAccount split)))
|
||||
(txn (xaccSplitGetParent split)))
|
||||
(if type
|
||||
(gnc-commodity-collector-add total acct-comm shares)
|
||||
(if (not (xaccTransGetIsClosingTxn txn))
|
||||
(gnc-commodity-collector-add total acct-comm shares)
|
||||
)))
|
||||
)
|
||||
(total 'add acct-comm shares)
|
||||
(if (not (xaccTransGetIsClosingTxn txn))
|
||||
(total 'add acct-comm shares)))))
|
||||
(gnc:account-get-trans-type-splits-interval
|
||||
account-list type start-date end-date)
|
||||
)
|
||||
total
|
||||
)
|
||||
)
|
||||
account-list type start-date end-date))
|
||||
total))
|
||||
|
||||
;; 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 (even closing splits)
|
||||
(define (gnc:account-get-trans-type-balance-interval-with-closing
|
||||
account-list type start-date end-date)
|
||||
(let* ((total (gnc:make-commodity-collector)))
|
||||
(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)
|
||||
)
|
||||
)
|
||||
(xaccSplitGetAccount split))))
|
||||
(total 'add acct-comm shares)))
|
||||
(gnc:account-get-trans-type-splits-interval
|
||||
account-list type start-date end-date)
|
||||
)
|
||||
total
|
||||
)
|
||||
)
|
||||
account-list type start-date end-date))
|
||||
total))
|
||||
|
||||
;; Filters the splits from the source to the target accounts
|
||||
;; returns a commodity collector
|
||||
;; does NOT do currency exchanges
|
||||
(define (gnc:account-get-total-flow direction target-account-list from-date to-date)
|
||||
|
||||
(let* (
|
||||
(total-flow (gnc:make-commodity-collector))
|
||||
)
|
||||
|
||||
;; ------------------------------------------------------------------
|
||||
;; process all target accounts
|
||||
;; ------------------------------------------------------------------
|
||||
(let ((total-flow (gnc:make-commodity-collector)))
|
||||
(for-each
|
||||
(lambda (target-account)
|
||||
;; -------------------------------------
|
||||
;; process all splits of current account
|
||||
;; -------------------------------------
|
||||
(for-each
|
||||
(lambda (target-account-split)
|
||||
;; ----------------------------------------------------
|
||||
;; only target account splits that are within the specified time range
|
||||
;; ----------------------------------------------------
|
||||
(let* (
|
||||
(transaction (xaccSplitGetParent target-account-split))
|
||||
(transaction-date-posted (xaccTransGetDate transaction))
|
||||
)
|
||||
(if (and
|
||||
(<= transaction-date-posted to-date)
|
||||
(>= transaction-date-posted from-date)
|
||||
)
|
||||
;; -------------------------------------------------------------
|
||||
;; get the split information
|
||||
;; -------------------------------------------------------------
|
||||
(let* (
|
||||
(transaction-currency (xaccTransGetCurrency transaction))
|
||||
(transaction-value (gnc-numeric-zero))
|
||||
(split-value (xaccSplitGetAmount target-account-split))
|
||||
)
|
||||
;; -------------------------------------------------------------
|
||||
;; update the return value
|
||||
;; -------------------------------------------------------------
|
||||
(case direction
|
||||
((in)
|
||||
(if (gnc-numeric-positive-p split-value)
|
||||
(total-flow 'add transaction-currency split-value)
|
||||
)
|
||||
)
|
||||
((out)
|
||||
(if (gnc-numeric-negative-p split-value)
|
||||
(total-flow 'add transaction-currency split-value)
|
||||
)
|
||||
)
|
||||
(else (gnc:warn "bad gnc:account-get-total-flow action: " direction))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(xaccAccountGetSplitList target-account)
|
||||
)
|
||||
)
|
||||
target-account-list
|
||||
)
|
||||
total-flow ;; RETURN
|
||||
)
|
||||
)
|
||||
(lambda (target-account)
|
||||
(for-each
|
||||
(lambda (target-account-split)
|
||||
(let* ((transaction (xaccSplitGetParent target-account-split))
|
||||
(split-value (xaccSplitGetAmount target-account-split)))
|
||||
(if (and (<= from-date (xaccTransGetDate transaction) to-date)
|
||||
(or (and (eq? direction 'in)
|
||||
(positive? split-value))
|
||||
(and (eq? direction 'out)
|
||||
(negative? split-value))))
|
||||
(total-flow 'add (xaccTransGetCurrency transaction) split-value))))
|
||||
(xaccAccountGetSplitList target-account)))
|
||||
target-account-list)
|
||||
total-flow))
|
||||
|
||||
;; similar, but only counts transactions with non-negative shares and
|
||||
;; *ignores* any closing entries
|
||||
@ -855,7 +737,7 @@
|
||||
(xaccSplitGetAccount split)))
|
||||
)
|
||||
(or (gnc-numeric-negative-p shares)
|
||||
(gnc-commodity-collector-add total acct-comm shares)
|
||||
(total 'add acct-comm shares)
|
||||
)
|
||||
)
|
||||
)
|
||||
@ -970,15 +852,11 @@
|
||||
|
||||
|
||||
(define (gnc:budget-accountlist-helper accountlist get-fn)
|
||||
(let
|
||||
(
|
||||
(net (gnc:make-commodity-collector)))
|
||||
(let ((net (gnc:make-commodity-collector)))
|
||||
(for-each
|
||||
(lambda (account)
|
||||
(net 'merge
|
||||
(get-fn account)
|
||||
#f))
|
||||
accountlist)
|
||||
(lambda (account)
|
||||
(net 'merge (get-fn account) #f))
|
||||
accountlist)
|
||||
net))
|
||||
|
||||
;; Sums budget values for a single account from start-period (inclusive) to
|
||||
@ -989,17 +867,14 @@
|
||||
;;
|
||||
;; Returns a commodity-collector.
|
||||
(define (gnc:budget-account-get-net budget account start-period end-period)
|
||||
(if (not start-period) (set! start-period 0))
|
||||
(if (not end-period) (set! end-period (gnc-budget-get-num-periods budget)))
|
||||
(let*
|
||||
(
|
||||
(period start-period)
|
||||
(net (gnc:make-commodity-collector))
|
||||
(acct-comm (xaccAccountGetCommodity account)))
|
||||
(let* ((period (or start-period 0))
|
||||
(net (gnc:make-commodity-collector))
|
||||
(acct-comm (xaccAccountGetCommodity account)))
|
||||
(while (< period end-period)
|
||||
(net 'add acct-comm
|
||||
(gnc-budget-get-account-period-value budget account period))
|
||||
(set! period (+ period 1)))
|
||||
(gnc-budget-get-account-period-value budget account period))
|
||||
(set! period (1+ period)))
|
||||
net))
|
||||
|
||||
;; Sums budget values for accounts in accountlist from start-period (inclusive)
|
||||
@ -1046,18 +921,10 @@
|
||||
;; Return value:
|
||||
;; budget value to use for account for specified period.
|
||||
(define (budget-account-sum budget children period)
|
||||
(let* ((sum
|
||||
(cond
|
||||
((null? children) (gnc-numeric-zero))
|
||||
(else
|
||||
(gnc-numeric-add
|
||||
(gnc:get-account-period-rolledup-budget-value budget (car children) period)
|
||||
(budget-account-sum budget (cdr children) period)
|
||||
GNC-DENOM-AUTO GNC-RND-ROUND))
|
||||
)
|
||||
))
|
||||
sum)
|
||||
)
|
||||
(apply + (map
|
||||
(lambda (child)
|
||||
(gnc:get-account-period-rolledup-budget-value budget child period))
|
||||
children)))
|
||||
|
||||
;; Calculate the value to use for the budget of an account for a specific period.
|
||||
;; - If the account has a budget value set for the period, use it
|
||||
@ -1073,14 +940,11 @@
|
||||
;; sum of all budgets for list of children for specified period.
|
||||
(define (gnc:get-account-period-rolledup-budget-value budget acct period)
|
||||
(let* ((bgt-set? (gnc-budget-is-account-period-value-set budget acct period))
|
||||
(children (gnc-account-get-children acct))
|
||||
(amount (cond
|
||||
(bgt-set? (gnc-budget-get-account-period-value budget acct period))
|
||||
((not (null? children)) (budget-account-sum budget children period))
|
||||
(else (gnc-numeric-zero)))
|
||||
))
|
||||
amount)
|
||||
)
|
||||
(children (gnc-account-get-children acct)))
|
||||
(cond
|
||||
(bgt-set? (gnc-budget-get-account-period-value budget acct period))
|
||||
((not (null? children)) (budget-account-sum budget children period))
|
||||
(else 0))))
|
||||
|
||||
;; Sums rolled-up budget values for a single account from start-period (inclusive) to
|
||||
;; end-period (exclusive).
|
||||
@ -1093,57 +957,45 @@
|
||||
;;
|
||||
;; Returns a gnc-numeric value
|
||||
(define (gnc:budget-account-get-rolledup-net budget account start-period end-period)
|
||||
(if (not start-period) (set! start-period 0))
|
||||
(if (not end-period) (set! end-period (gnc-budget-get-num-periods budget)))
|
||||
(let*
|
||||
(
|
||||
(period start-period)
|
||||
(net (gnc-numeric-zero))
|
||||
(acct-comm (xaccAccountGetCommodity account)))
|
||||
(while (< period end-period)
|
||||
(set! net (gnc-numeric-add net
|
||||
(gnc:get-account-period-rolledup-budget-value budget account period)
|
||||
GNC-DENOM-AUTO GNC-RND-ROUND))
|
||||
(set! period (+ period 1)))
|
||||
net))
|
||||
(let* ((start (or start-period 0))
|
||||
(end (or end-period (gnc-budget-get-num-periods budget)))
|
||||
(numperiods (- end start -1)))
|
||||
(apply +
|
||||
(map
|
||||
(lambda (period)
|
||||
(gnc:get-account-period-rolledup-budget-value budget account period))
|
||||
(iota numperiods start 1)))))
|
||||
|
||||
;; ***************************************************************************
|
||||
;; The following 3 functions belong together
|
||||
;; Input: accounts, get-balance-fn
|
||||
;; Output: account-balances, a list of 2-element lists
|
||||
|
||||
(define (gnc:get-assoc-account-balances accounts get-balance-fn)
|
||||
(let*
|
||||
(
|
||||
(initial-balances (list)))
|
||||
(for-each
|
||||
(lambda (account)
|
||||
(set! initial-balances
|
||||
(append initial-balances
|
||||
(list (list account (get-balance-fn account))))))
|
||||
accounts)
|
||||
initial-balances))
|
||||
(map
|
||||
(lambda (acct)
|
||||
(list acct (get-balance-fn acct)))
|
||||
accounts))
|
||||
|
||||
;; Input: account-balances, account
|
||||
;; Output: commodity-collector
|
||||
(define (gnc:select-assoc-account-balance account-balances account)
|
||||
(let*
|
||||
(
|
||||
(account-balance (car account-balances))
|
||||
(result
|
||||
(if
|
||||
(equal? account-balance '())
|
||||
#f
|
||||
(if
|
||||
(equal? (car account-balance) account)
|
||||
(car (cdr account-balance))
|
||||
(gnc:select-assoc-account-balance
|
||||
(cdr account-balances)
|
||||
account)))))
|
||||
result))
|
||||
(let ((found (find
|
||||
(lambda (acct-bal)
|
||||
(equal? (car acct-bal) account))
|
||||
account-balances)))
|
||||
(and found (cadr found))))
|
||||
|
||||
;; Input: account-balances
|
||||
;; Output: commodity-collector
|
||||
(define (gnc:get-assoc-account-balances-total account-balances)
|
||||
(let
|
||||
(
|
||||
(total (gnc:make-commodity-collector)))
|
||||
(let ((total (gnc:make-commodity-collector)))
|
||||
(for-each
|
||||
(lambda (account-balance)
|
||||
(total 'merge (car (cdr account-balance)) #f))
|
||||
account-balances)
|
||||
(lambda (account-balance)
|
||||
(total 'merge (cadr account-balance) #f))
|
||||
account-balances)
|
||||
total))
|
||||
;; ***************************************************************************
|
||||
|
||||
;; Adds "file:///" to the beginning of a URL if it doesn't already exist
|
||||
;;
|
||||
|
||||
@ -72,9 +72,6 @@
|
||||
(define gnc:optname-stylesheet (N_ "Stylesheet"))
|
||||
(define gnc:menuname-business-reports (N_ "_Business"))
|
||||
(define gnc:optname-invoice-number (N_ "Invoice Number"))
|
||||
(define test-report-system-flag #f)
|
||||
|
||||
(export test-report-system-flag)
|
||||
|
||||
;; We want to warn users if they've got an old-style, non-guid custom
|
||||
;; report-template, but only once
|
||||
@ -142,7 +139,7 @@
|
||||
;; FIXME: We should pass the top-level window
|
||||
;; instead of the '() to gnc-error-dialog, but I
|
||||
;; have no idea where to get it from.
|
||||
(if (not test-report-system-flag)
|
||||
(if (gnucash-ui-is-running)
|
||||
(gnc-error-dialog '() (string-append
|
||||
(_ "One of your reports has a report-guid that is a duplicate. Please check the report system, especially your saved reports, for a report with this report-guid: ")
|
||||
report-guid))
|
||||
@ -175,14 +172,14 @@
|
||||
(if (not gnc:old-style-report-warned)
|
||||
(begin
|
||||
(set! gnc:old-style-report-warned #t)
|
||||
(if (not test-report-system-flag) ;; do not call this during "make test"
|
||||
(if (gnucash-ui-is-running)
|
||||
(gnc-error-dialog '() (string-append (_ "The GnuCash report system has been upgraded. Your old saved reports have been transferred into a new format. If you experience trouble with saved reports, please contact the GnuCash development team."))))
|
||||
(hash-set! *gnc:_report-templates_* (gnc:report-template-report-guid report-rec) report-rec)
|
||||
)
|
||||
)
|
||||
)
|
||||
;;there is no parent -> this is an inital faulty report definition
|
||||
(if (not test-report-system-flag) ;; do not call this during "make test"
|
||||
(if (gnucash-ui-is-running)
|
||||
(gnc-error-dialog '() (string-append (_ "Wrong report definition: ")
|
||||
(gnc:report-template-name report-rec)
|
||||
(_ " Report is missing a GUID.")))
|
||||
|
||||
@ -8,7 +8,6 @@
|
||||
(use-modules (gnucash engine test srfi64-extras))
|
||||
|
||||
(define (run-test)
|
||||
(set! test-report-system-flag #t)
|
||||
(test-runner-factory gnc:test-runner)
|
||||
(test-begin "Testing/Temporary/test-report-system") ;; if (test-runner-factory gnc:test-runner) is commented out, this
|
||||
;; will create Testing/Temporary/test-asset-performance.log
|
||||
@ -16,7 +15,6 @@
|
||||
(test-assert "Missing GUID detection" (test-check2))
|
||||
(test-assert "Detect double GUID" (test-check3))
|
||||
(test-assert "Report with Full Argument Set" (test-check4))
|
||||
(set! test-report-system-flag #f)
|
||||
(test-end "Testing/Temporary/test-report-system")
|
||||
)
|
||||
|
||||
|
||||
@ -473,10 +473,10 @@ by preventing negative stock balances.<br/>")
|
||||
(exchange-fn fromunits tocurrency)))
|
||||
|
||||
(gnc:debug "Starting account " (xaccAccountGetName current) ", initial price: "
|
||||
(if price
|
||||
(gnc-commodity-value->string
|
||||
(list (gnc-price-get-currency price) (gnc-price-get-value price)))
|
||||
#f))
|
||||
(and price
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
(gnc-price-get-currency price) (gnc-price-get-value price)))))
|
||||
|
||||
;; If we have a price that can't be converted to the report currency
|
||||
;; don't use it
|
||||
@ -535,7 +535,8 @@ by preventing negative stock balances.<br/>")
|
||||
;; Now that we have a pricing transaction if needed, set the value of the asset
|
||||
(set! value (my-exchange-fn (gnc:make-gnc-monetary commodity units) currency))
|
||||
(gnc:debug "Value " (gnc:monetary->string value)
|
||||
" from " (gnc-commodity-numeric->string commodity units))
|
||||
" from " (gnc:monetary->string
|
||||
(gnc:make-gnc-monetary commodity units)))
|
||||
|
||||
(for-each
|
||||
;; we're looking at each split we find in the account. these splits
|
||||
|
||||
@ -1305,10 +1305,8 @@ be excluded from periodic reporting.")
|
||||
(define indent-level
|
||||
(+ primary-indent secondary-indent))
|
||||
|
||||
|
||||
(define (add-subheading data subheading-style split level)
|
||||
(let* ((row-contents '())
|
||||
(sortkey (opt-val pagename-sorting
|
||||
(let* ((sortkey (opt-val pagename-sorting
|
||||
(case level
|
||||
((primary) optname-prime-sortkey)
|
||||
((secondary) optname-sec-sortkey))))
|
||||
@ -1316,31 +1314,36 @@ be excluded from periodic reporting.")
|
||||
((primary total) 0)
|
||||
((secondary) primary-indent)))
|
||||
(right-indent (- indent-level left-indent)))
|
||||
(for-each (lambda (cell) (addto! row-contents cell))
|
||||
(gnc:html-make-empty-cells left-indent))
|
||||
(if (and (opt-val pagename-sorting optname-show-informal-headers)
|
||||
(column-uses? 'amount-double)
|
||||
(member sortkey SORTKEY-INFORMAL-HEADERS))
|
||||
(begin
|
||||
(if export?
|
||||
(begin
|
||||
(addto! row-contents (gnc:make-html-table-cell data))
|
||||
(for-each (lambda (cell) (addto! row-contents cell))
|
||||
(gnc:html-make-empty-cells (+ right-indent width-left-columns -1))))
|
||||
(addto! row-contents (gnc:make-html-table-cell/size
|
||||
1 (+ right-indent width-left-columns) data)))
|
||||
(for-each (lambda (cell)
|
||||
(addto! row-contents
|
||||
(gnc:make-html-text
|
||||
(gnc:html-markup-b
|
||||
((vector-ref cell 5)
|
||||
((keylist-get-info (sortkey-list BOOK-SPLIT-ACTION) sortkey 'renderer-fn) split))))))
|
||||
calculated-cells))
|
||||
(addto! row-contents (gnc:make-html-table-cell/size
|
||||
1 (+ right-indent width-left-columns width-right-columns) data)))
|
||||
|
||||
(if (not (column-uses? 'subtotals-only))
|
||||
(gnc:html-table-append-row/markup! table subheading-style (reverse row-contents)))))
|
||||
(unless (column-uses? 'subtotals-only)
|
||||
(gnc:html-table-append-row/markup!
|
||||
table subheading-style
|
||||
(append
|
||||
(gnc:html-make-empty-cells left-indent)
|
||||
(if (and (opt-val pagename-sorting optname-show-informal-headers)
|
||||
(column-uses? 'amount-double)
|
||||
(member sortkey SORTKEY-INFORMAL-HEADERS))
|
||||
(append
|
||||
(if export?
|
||||
(cons
|
||||
(gnc:make-html-table-cell data)
|
||||
(gnc:html-make-empty-cells
|
||||
(+ right-indent width-left-columns -1)))
|
||||
(list
|
||||
(gnc:make-html-table-cell/size
|
||||
1 (+ right-indent width-left-columns) data)))
|
||||
(map (lambda (cell)
|
||||
(gnc:make-html-text
|
||||
(gnc:html-markup-b
|
||||
((vector-ref cell 5)
|
||||
((keylist-get-info (sortkey-list BOOK-SPLIT-ACTION)
|
||||
sortkey 'renderer-fn)
|
||||
split)))))
|
||||
calculated-cells))
|
||||
(list
|
||||
(gnc:make-html-table-cell/size
|
||||
1 (+ right-indent width-left-columns width-right-columns)
|
||||
data))))))))
|
||||
|
||||
(define (add-subtotal-row subtotal-string subtotal-collectors subtotal-style level row col)
|
||||
(let* ((left-indent (case level
|
||||
@ -1506,65 +1509,46 @@ be excluded from periodic reporting.")
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (add-split-row split cell-calculators row-style transaction-row?)
|
||||
(let* ((row-contents '())
|
||||
(trans (xaccSplitGetParent split))
|
||||
(account (xaccSplitGetAccount split)))
|
||||
(let* ((account (xaccSplitGetAccount split))
|
||||
(reversible-account? (if account-types-to-reverse
|
||||
(member (xaccAccountGetType account)
|
||||
account-types-to-reverse)
|
||||
(gnc-reverse-balance account)))
|
||||
(cells (map (lambda (cell)
|
||||
(let* ((split->monetary (vector-ref cell 1)))
|
||||
(vector (split->monetary split)
|
||||
(vector-ref cell 2) ;reverse?
|
||||
(vector-ref cell 3) ;subtotal?
|
||||
)))
|
||||
cell-calculators)))
|
||||
|
||||
(define left-cols
|
||||
(map (lambda (left-col)
|
||||
(let* ((col-fn (vector-ref left-col 1))
|
||||
(col-data (col-fn split transaction-row?)))
|
||||
col-data))
|
||||
left-columns))
|
||||
|
||||
(define cells
|
||||
(map (lambda (cell)
|
||||
(let* ((calculator (vector-ref cell 1))
|
||||
(reverse? (vector-ref cell 2))
|
||||
(subtotal? (vector-ref cell 3))
|
||||
(calculated (calculator split)))
|
||||
(vector calculated
|
||||
reverse?
|
||||
subtotal?)))
|
||||
cell-calculators))
|
||||
|
||||
(for-each (lambda (cell) (addto! row-contents cell))
|
||||
(gnc:html-make-empty-cells indent-level))
|
||||
|
||||
(for-each (lambda (col)
|
||||
(addto! row-contents col))
|
||||
left-cols)
|
||||
|
||||
(for-each (lambda (cell)
|
||||
(let ((cell-content (vector-ref cell 0))
|
||||
;; reverse? returns a bool - will check if the cell type has reversible sign,
|
||||
;; whether the account is also reversible according to Report Option, or
|
||||
;; if Report Option follows Global Settings, will retrieve bool from it.
|
||||
(reverse? (and (vector-ref cell 1)
|
||||
(if account-types-to-reverse
|
||||
(member (xaccAccountGetType account) account-types-to-reverse)
|
||||
(gnc-reverse-balance account)))))
|
||||
(if cell-content
|
||||
(addto! row-contents
|
||||
(gnc:make-html-table-cell/markup
|
||||
"number-cell"
|
||||
(gnc:html-transaction-anchor
|
||||
trans
|
||||
;; if conditions for reverse are satisfied, apply sign reverse to
|
||||
;; monetary amount
|
||||
(if reverse?
|
||||
(gnc:monetary-neg cell-content)
|
||||
cell-content))))
|
||||
(addto! row-contents (gnc:html-make-empty-cell)))))
|
||||
cells)
|
||||
|
||||
(if (not (column-uses? 'subtotals-only))
|
||||
(gnc:html-table-append-row/markup! table row-style (reverse row-contents)))
|
||||
(unless (column-uses? 'subtotals-only)
|
||||
(gnc:html-table-append-row/markup!
|
||||
table row-style
|
||||
(append
|
||||
(gnc:html-make-empty-cells indent-level)
|
||||
(map (lambda (left-col)
|
||||
((vector-ref left-col 1)
|
||||
split transaction-row?))
|
||||
left-columns)
|
||||
(map (lambda (cell)
|
||||
(let ((cell-monetary (vector-ref cell 0))
|
||||
(reverse? (and (vector-ref cell 1)
|
||||
reversible-account?)))
|
||||
(and cell-monetary
|
||||
(gnc:make-html-table-cell/markup
|
||||
"number-cell"
|
||||
(gnc:html-transaction-anchor
|
||||
(xaccSplitGetParent split)
|
||||
(if reverse?
|
||||
(gnc:monetary-neg cell-monetary)
|
||||
cell-monetary))))))
|
||||
cells))))
|
||||
|
||||
(map (lambda (cell)
|
||||
(let ((cell-content (vector-ref cell 0))
|
||||
(let ((cell-monetary (vector-ref cell 0))
|
||||
(subtotal? (vector-ref cell 2)))
|
||||
(and subtotal? cell-content)))
|
||||
(and subtotal? cell-monetary)))
|
||||
cells)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@ -1621,23 +1605,23 @@ be excluded from periodic reporting.")
|
||||
(add-split-row othersplits calculated-cells def:alternate-row-style #f))
|
||||
(delete current (xaccTransGetSplitList (xaccSplitGetParent current)))))
|
||||
|
||||
(map (lambda (collector value)
|
||||
(if value
|
||||
(collector 'add (gnc:gnc-monetary-commodity value) (gnc:gnc-monetary-amount value))))
|
||||
primary-subtotal-collectors
|
||||
split-values)
|
||||
(for-each
|
||||
(lambda (collector value)
|
||||
(if value
|
||||
(collector 'add (gnc:gnc-monetary-commodity value) (gnc:gnc-monetary-amount value))))
|
||||
primary-subtotal-collectors split-values)
|
||||
|
||||
(map (lambda (collector value)
|
||||
(if value
|
||||
(collector 'add (gnc:gnc-monetary-commodity value) (gnc:gnc-monetary-amount value))))
|
||||
secondary-subtotal-collectors
|
||||
split-values)
|
||||
(for-each
|
||||
(lambda (collector value)
|
||||
(if value
|
||||
(collector 'add (gnc:gnc-monetary-commodity value) (gnc:gnc-monetary-amount value))))
|
||||
secondary-subtotal-collectors split-values)
|
||||
|
||||
(map (lambda (collector value)
|
||||
(if value
|
||||
(collector 'add (gnc:gnc-monetary-commodity value) (gnc:gnc-monetary-amount value))))
|
||||
total-collectors
|
||||
split-values)
|
||||
(for-each
|
||||
(lambda (collector value)
|
||||
(if value
|
||||
(collector 'add (gnc:gnc-monetary-commodity value) (gnc:gnc-monetary-amount value))))
|
||||
total-collectors split-values)
|
||||
|
||||
(if (and primary-subtotal-comparator
|
||||
(or (not next)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user