mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
[commodity-utils] refactor totalavg price calculator
use exact rationals, therefore test suite amended
This commit is contained in:
Christopher Lam
@@ -121,86 +121,66 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
|
||||
currency-accounts end-date price-commodity)))
|
||||
|
||||
(define (gnc:get-commodity-totalavg-prices-internal
|
||||
currency-accounts end-date price-commodity report-currency
|
||||
commodity-splits)
|
||||
(let ((total-foreign 0)
|
||||
(total-domestic 0))
|
||||
(filter
|
||||
gnc:price-is-not-zero?
|
||||
(map-in-order
|
||||
(lambda (a)
|
||||
(let* ((transaction-comm (xaccTransGetCurrency
|
||||
(xaccSplitGetParent a)))
|
||||
(account-comm (xaccAccountGetCommodity
|
||||
(xaccSplitGetAccount a)))
|
||||
(share-amount (abs
|
||||
(xaccSplitGetAmount a)))
|
||||
(value-amount (abs
|
||||
(xaccSplitGetValue a)))
|
||||
(transaction-date (xaccTransGetDate
|
||||
(xaccSplitGetParent a)))
|
||||
(foreignlist
|
||||
(if (and
|
||||
(not (zero? share-amount))
|
||||
(not (zero? value-amount)))
|
||||
(if (gnc-commodity-equiv transaction-comm
|
||||
price-commodity)
|
||||
(list account-comm
|
||||
share-amount value-amount)
|
||||
(list transaction-comm
|
||||
value-amount share-amount))
|
||||
#f)))
|
||||
currency-accounts end-date price-commodity report-currency commodity-splits)
|
||||
(let loop ((tot-foreign 0)
|
||||
(tot-domestic 0)
|
||||
(commodity-splits commodity-splits)
|
||||
(result '()))
|
||||
(if (null? commodity-splits)
|
||||
(reverse! result)
|
||||
(let* ((a (car commodity-splits))
|
||||
(share-amt (abs (xaccSplitGetAmount a)))
|
||||
(value-amt (abs (xaccSplitGetValue a)))
|
||||
(txn-comm (xaccTransGetCurrency (xaccSplitGetParent a)))
|
||||
(acc-comm (xaccAccountGetCommodity (xaccSplitGetAccount a)))
|
||||
(txn-date (xaccTransGetDate (xaccSplitGetParent a))))
|
||||
(cond
|
||||
((or (zero? share-amt) (zero? value-amt))
|
||||
(loop tot-foreign
|
||||
tot-domestic
|
||||
(cdr commodity-splits)
|
||||
result))
|
||||
|
||||
;; Try EURO exchange if necessary
|
||||
(if (and foreignlist
|
||||
(not (gnc-commodity-equiv (car foreignlist)
|
||||
report-currency)))
|
||||
(let ((exchanged (gnc:exchange-by-euro-numeric
|
||||
(car foreignlist) (cadr foreignlist)
|
||||
report-currency transaction-date)))
|
||||
(if exchanged
|
||||
(set! foreignlist
|
||||
(list report-currency
|
||||
(gnc:gnc-monetary-amount exchanged)
|
||||
(caddr foreignlist))))))
|
||||
((gnc-commodity-equiv acc-comm report-currency)
|
||||
(let ((new-foreign (+ tot-foreign value-amt))
|
||||
(new-domestic (+ tot-domestic share-amt)))
|
||||
(loop new-foreign
|
||||
new-domestic
|
||||
(cdr commodity-splits)
|
||||
(cons (list txn-date (/ new-domestic new-foreign)) result))))
|
||||
|
||||
(list
|
||||
transaction-date
|
||||
(if foreignlist
|
||||
(if (not (gnc-commodity-equiv (car foreignlist)
|
||||
report-currency))
|
||||
(begin
|
||||
(warn "gnc:get-commodity-totalavg-prices: "
|
||||
"Sorry, currency exchange not yet implemented:"
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
(car foreignlist) (cadr foreignlist)))
|
||||
" (buying "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
price-commodity (caddr foreignlist)))
|
||||
") =? "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
report-currency 0)))
|
||||
0)
|
||||
(begin
|
||||
(set! total-foreign (gnc-numeric-add total-foreign
|
||||
(caddr foreignlist)
|
||||
GNC-DENOM-AUTO
|
||||
GNC-DENOM-LCD))
|
||||
(set! total-domestic (gnc-numeric-add total-domestic
|
||||
(cadr foreignlist)
|
||||
GNC-DENOM-AUTO
|
||||
GNC-DENOM-LCD))
|
||||
(if (not (zero? total-foreign))
|
||||
(gnc-numeric-div
|
||||
total-domestic
|
||||
total-foreign
|
||||
GNC-DENOM-AUTO
|
||||
(logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND)) 0)))
|
||||
#f))))
|
||||
commodity-splits))))
|
||||
((gnc-commodity-equiv txn-comm report-currency)
|
||||
(let ((new-foreign (+ tot-foreign share-amt))
|
||||
(new-domestic (+ tot-domestic value-amt)))
|
||||
(loop new-foreign
|
||||
new-domestic
|
||||
(cdr commodity-splits)
|
||||
(cons (list txn-date (/ new-domestic new-foreign)) result))))
|
||||
|
||||
((gnc:exchange-by-euro-numeric txn-comm value-amt report-currency txn-date)
|
||||
=> (lambda (amt)
|
||||
(let ((new-foreign (+ tot-foreign share-amt))
|
||||
(new-domestic (+ tot-domestic (gnc:gnc-monetary-amount amt))))
|
||||
(loop new-foreign
|
||||
new-domestic
|
||||
(cdr commodity-splits)
|
||||
(cons (list txn-date (/ new-domestic new-foreign)) result)))))
|
||||
|
||||
(else
|
||||
(warn "gnc:get-commodity-totalavg-prices: "
|
||||
"Sorry, currency exchange not yet implemented:"
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary txn-comm value-amt))
|
||||
" (buying "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary price-commodity share-amt))
|
||||
") =? "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary report-currency 0)))
|
||||
(loop tot-foreign
|
||||
tot-domestic
|
||||
(cdr commodity-splits)
|
||||
result)))))))
|
||||
|
||||
|
||||
;; Create a list of prices for all commodities in 'commodity-list',
|
||||
|
||||
@@ -566,26 +566,22 @@
|
||||
(test-equal "MSFT totalavg 2012-01-15" (/ 4216500/100 1500)
|
||||
(cadr (assoc (gnc-dmy2time64-neutral 15 01 2012)
|
||||
report-list)))
|
||||
;; We have to use gnc-numeric-div with rounding in order to match the results
|
||||
;; from the function. Astute observers will notice that the totals include the
|
||||
;; Astute observers will notice that the totals include the
|
||||
;; capital gain split but not the acutal sell split on the day because the
|
||||
;; capital gain price is first in the list so that's the one (assoc) finds. See
|
||||
;; the comment at the gnc:get-commodity-totalavg-prices definition for more
|
||||
;; about the prices from this function.
|
||||
(test-equal "MSFT totalavg 2014-12-05"
|
||||
(gnc-numeric-div 6637500/100 2000 GNC-DENOM-AUTO
|
||||
(logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND))
|
||||
(cadr (assoc (gnc-dmy2time64-neutral 5 12 2014)
|
||||
report-list)))
|
||||
(/ 6637500/100 2000)
|
||||
(cadr (assoc (gnc-dmy2time64-neutral 5 12 2014)
|
||||
report-list)))
|
||||
(test-equal "MSFT totalavg 2015-04-02"
|
||||
(gnc-numeric-div 9860700/100 2800 GNC-DENOM-AUTO
|
||||
(logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND))
|
||||
(cadr (assoc (gnc-dmy2time64-neutral 2 4 2015) report-list)))
|
||||
(/ 9860700/100 2800)
|
||||
(cadr (assoc (gnc-dmy2time64-neutral 2 4 2015) report-list)))
|
||||
(test-equal "MSFT totalavg 2016-03-11"
|
||||
(gnc-numeric-div 14637000/100 3700 GNC-DENOM-AUTO
|
||||
(logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND))
|
||||
(cadr (assoc (gnc-dmy2time64-neutral 11 3 2016)
|
||||
report-list))))
|
||||
(/ 14637000/100 3700)
|
||||
(cadr (assoc (gnc-dmy2time64-neutral 11 3 2016)
|
||||
report-list))))
|
||||
(test-end "Microsoft-USD")
|
||||
|
||||
(test-begin "Daimler-DEM")
|
||||
|
||||
Reference in New Issue
Block a user