mirror of https://github.com/Gnucash/gnucash
* src/scm/commodity-utilities.scm: Functions to calculate exchange rates (weighted average) for different commodities (moved from report-utilities.scm). Major cleanup. * src/scm/options-utilities.scm: Option creation functions common to several reports. (moved from report-utilities.scm) * src/scm/report-utilities.scm: Major cleanup. git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@3631 57a11ea4-9604-0410-9ed3-97b8803252fdzzzoldreleases/1.6
Dave Peticolas
26 years ago
parent
999ceb2a5d
commit
5dd4c94809
@ -0,0 +1,299 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; commodity-utilities.scm: Functions for handling different commodities.
|
||||
;; Copyright 2001 Christian Stimming <stimming@tu-harburg.de>
|
||||
;;
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 2 of
|
||||
;; the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; if not, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(gnc:support "commodity-utilities.scm")
|
||||
(gnc:depend "report-utilities.scm")
|
||||
|
||||
;; All the functions below up to gnc:make-exchange-fn are calculating
|
||||
;; the exchange rate for different commodities by determining the
|
||||
;; weighted average of all currency transactions.
|
||||
|
||||
;; Returns a list of all splits in the currency-accounts up to
|
||||
;; end-date which have two *different* commodities involved.
|
||||
(define (gnc:get-all-commodity-splits
|
||||
currency-accounts end-date-tp)
|
||||
(let ((query (gnc:malloc-query))
|
||||
(splits #f))
|
||||
|
||||
(gnc:query-set-group query (gnc:get-current-group))
|
||||
(gnc:query-add-account-match
|
||||
query (gnc:list->glist currency-accounts)
|
||||
'acct-match-any 'query-and)
|
||||
(gnc:query-add-date-match-timepair
|
||||
query #f end-date-tp #t end-date-tp 'query-and)
|
||||
|
||||
;; Get the query result, i.e. all splits in currency
|
||||
;; accounts.
|
||||
(set! splits (filter
|
||||
;; Filter such that we get only those splits
|
||||
;; which have two *different* commodities
|
||||
;; involved.
|
||||
(lambda (s) (not (gnc:commodity-equiv?
|
||||
(gnc:transaction-get-commodity
|
||||
(gnc:split-get-parent s))
|
||||
(gnc:account-get-commodity
|
||||
(gnc:split-get-account s)))))
|
||||
(gnc:glist->list
|
||||
(gnc:query-get-splits query)
|
||||
<gnc:Split*>)))
|
||||
(gnc:free-query query)
|
||||
splits))
|
||||
|
||||
|
||||
;; Go through all toplevel non-report-commodity balances in sumlist
|
||||
;; and add them to report-commodity, if possible. This function takes
|
||||
;; a sumlist (described below) and returns an alist similar to one
|
||||
;; value of the sumlist's alist, e.g. (cadr (assoc report-commodity
|
||||
;; sumlist))). This resulting alist can immediately be plugged into
|
||||
;; gnc:make-exchange-alist.
|
||||
(define (gnc:resolve-unknown-comm sumlist report-commodity)
|
||||
;; reportlist contains all known transactions with the
|
||||
;; report-commodity, and now the transactions with unknown
|
||||
;; currencies should be added to that list (with an appropriate
|
||||
;; exchange rate).
|
||||
(let ((reportlist (cadr (assoc report-commodity sumlist))))
|
||||
|
||||
;; Helper function to calculate (a*b)/c and create the new pair of
|
||||
;; numeric-collectors, where [abc] are numeric-collectors. See the
|
||||
;; real variable names below.
|
||||
(define (make-newrate unknown-coll un->known-coll known-pair)
|
||||
(let ((a (make-numeric-collector))
|
||||
(b (make-numeric-collector)))
|
||||
(a 'add (unknown-coll 'total #f))
|
||||
(b 'add
|
||||
(gnc:numeric-div
|
||||
(gnc:numeric-mul
|
||||
(un->known-coll 'total #f)
|
||||
((cdadr known-pair) 'total #f)
|
||||
GNC-DENOM-AUTO GNC-DENOM-REDUCE)
|
||||
((caadr known-pair) 'total #f)
|
||||
GNC-DENOM-AUTO GNC-DENOM-REDUCE))
|
||||
;; in other words: (/ (* (caadr un->known-coll) (cdadr
|
||||
;; known-pair)) (caadr known-pair) ))
|
||||
(cons a b)))
|
||||
|
||||
;; Go through sumlist.
|
||||
(for-each
|
||||
(lambda (otherlist)
|
||||
(if (not (gnc:commodity-equiv? (car otherlist) report-commodity))
|
||||
(for-each
|
||||
(lambda (pair)
|
||||
;; pair-{a,b}: Try to find either the currency of
|
||||
;; otherlist or of pair in reportlist.
|
||||
(let ((pair-a (assoc (car otherlist) reportlist))
|
||||
(pair-b (assoc (car pair) reportlist))
|
||||
(rate (gnc:numeric-zero)))
|
||||
(if (and (not pair-a) (not pair-b))
|
||||
;; If neither the currency of otherlist nor of
|
||||
;; pair was found in reportlist then we can't
|
||||
;; resolve the exchange rate to this currency.
|
||||
(warn "can't calculate rate for "
|
||||
(gnc:commodity-value->string
|
||||
(list (car pair) (caadr pair)))
|
||||
" = "
|
||||
(gnc:commodity-value->string
|
||||
(list (car otherlist) (cdadr pair)))
|
||||
" to "
|
||||
(gnc:commodity-value->string
|
||||
(list report-commodity (gnc:numeric-zero))))
|
||||
(if (and pair-a pair-b)
|
||||
;; If both currencies are found then something
|
||||
;; went wrong inside
|
||||
;; gnc:get-exchange-totals. FIXME: Find a
|
||||
;; better thing to do in this case.
|
||||
(warn "Oops - exchange rate ambiguity error: "
|
||||
(gnc:commodity-value->string
|
||||
(list (car pair) (caadr pair)))
|
||||
" = "
|
||||
(gnc:commodity-value->string
|
||||
(list (car otherlist) (cdadr pair))))
|
||||
(let
|
||||
;; Usual case: one of pair-{a,b} was found
|
||||
;; in reportlist, i.e. this transaction
|
||||
;; can be resolved to report-commodity.
|
||||
((newrate
|
||||
(if (not pair-a)
|
||||
(list (car otherlist)
|
||||
(make-newrate (cdadr pair)
|
||||
(caadr pair) pair-b))
|
||||
(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)))))))
|
||||
(cadr otherlist))))
|
||||
sumlist)
|
||||
|
||||
;; Return the reportlist.
|
||||
reportlist))
|
||||
;; Some thoughts: In the (and (not pair-a) (not pair-b)) case above we
|
||||
;; will have unresolvable transaction exchange rates. But there might
|
||||
;; be cases where we will be able to resolve this, but only after one
|
||||
;; or more runs of gnc:resolve-unknown-comm. Maybe we could transform
|
||||
;; this functions to use some kind of recursiveness.
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; In progress: A suggested function to calculate the weighted average
|
||||
;; exchange rate between all commodities and the
|
||||
;; report-commodity. Uses all currency transactions up until the
|
||||
;; end-date. Returns an alist, see sumlist.
|
||||
(define (gnc:get-exchange-totals report-commodity end-date)
|
||||
(let ((curr-accounts
|
||||
(filter gnc:account-has-shares? (gnc:group-get-subaccounts
|
||||
(gnc:get-current-group))))
|
||||
;; sumlist: a multilevel alist. Each element has a commodity
|
||||
;; as key, and another alist as a value. The value-alist's
|
||||
;; elements consist of a commodity as a key, and a pair of two
|
||||
;; value-collectors as value, e.g. with only one (the report-)
|
||||
;; commodity DEM in the outer alist: ( {DEM ( [USD (400 .
|
||||
;; 1000)] [FRF (300 . 100)] ) } ) where DEM,USD,FRF are
|
||||
;; <gnc:commodity> and the numbers are a numeric-collector
|
||||
;; which in turn store a <gnc:numeric>. In the example, USD
|
||||
;; 400 were bought for an amount of DEM 1000, FRF 300 were
|
||||
;; bought for DEM 100. The reason for the outer alist is that
|
||||
;; there might be commodity transactions which do not involve
|
||||
;; the report-commodity, but which can still be calculated
|
||||
;; after *all* transactions are processed.
|
||||
(sumlist (list (list report-commodity '()))))
|
||||
|
||||
(if (not (null? curr-accounts))
|
||||
;; Go through all splits and add up all value-amounts
|
||||
;; and share-amounts
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(let* ((transaction-comm (gnc:transaction-get-commodity
|
||||
(gnc:split-get-parent a)))
|
||||
(account-comm (gnc:account-get-commodity
|
||||
(gnc:split-get-account a)))
|
||||
(share-amount (gnc:split-get-share-amount a))
|
||||
(value-amount (gnc:split-get-value a))
|
||||
(tmp (assoc transaction-comm sumlist))
|
||||
(comm-list (if (not tmp)
|
||||
(assoc account-comm sumlist)
|
||||
tmp)))
|
||||
|
||||
;; entry exists already in comm-list?
|
||||
(if (not comm-list)
|
||||
;; no, create sub-alist from scratch
|
||||
(let ((pair (list transaction-comm
|
||||
(cons (make-numeric-collector)
|
||||
(make-numeric-collector)))))
|
||||
((caadr pair) 'add value-amount)
|
||||
((cdadr pair) 'add share-amount)
|
||||
(set! comm-list (list account-comm (list pair)))
|
||||
;; and add the new sub-alist to sumlist.
|
||||
(set! sumlist (cons comm-list sumlist)))
|
||||
;; yes, check for second commodity.
|
||||
(let*
|
||||
((foreignlist
|
||||
;; this will adjust the signs appropriately
|
||||
(if (gnc:commodity-equiv? transaction-comm
|
||||
(car comm-list))
|
||||
(list account-comm
|
||||
(gnc:numeric-neg share-amount)
|
||||
(gnc:numeric-neg value-amount))
|
||||
(list transaction-comm
|
||||
value-amount
|
||||
share-amount)))
|
||||
;; second commodity already existing in comm-list?
|
||||
(pair (assoc (car foreignlist) (cadr comm-list))))
|
||||
;; if not, create a new entry in comm-list.
|
||||
(if (not pair)
|
||||
(begin
|
||||
(set!
|
||||
pair (list (car foreignlist)
|
||||
(cons (make-numeric-collector)
|
||||
(make-numeric-collector))))
|
||||
(set!
|
||||
comm-list (list (car comm-list)
|
||||
(cons pair (cadr comm-list))))
|
||||
(set!
|
||||
sumlist (cons comm-list
|
||||
(alist-delete
|
||||
(car comm-list) sumlist)))))
|
||||
;; And add the balances to the comm-list entry.
|
||||
((caadr pair) 'add (cadr foreignlist))
|
||||
((cdadr pair) 'add (caddr foreignlist))))))
|
||||
(gnc:get-all-commodity-splits curr-accounts end-date)))
|
||||
|
||||
(gnc:resolve-unknown-comm sumlist report-commodity)))
|
||||
|
||||
;; Anybody feel free to reimplement any of these functions, either in
|
||||
;; scheme or in C. -- cstim
|
||||
|
||||
(define (gnc:make-exchange-alist report-commodity end-date)
|
||||
;; This returns the alist with the actual exchange rates, i.e. the
|
||||
;; total balances from get-exchange-totals are divided by each
|
||||
;; other.
|
||||
(map
|
||||
(lambda (e)
|
||||
(list (car e)
|
||||
(gnc:numeric-abs
|
||||
(gnc:numeric-div ((cdadr e) 'total #f)
|
||||
((caadr e) 'total #f)
|
||||
GNC-DENOM-AUTO
|
||||
GNC-DENOM-REDUCE))))
|
||||
(gnc:get-exchange-totals report-commodity end-date)))
|
||||
|
||||
;; This one returns the ready-to-use function for calculation of the
|
||||
;; exchange rates. The returned function in turn returns a pair
|
||||
;; commodity - value which instantly can be plugged into
|
||||
;; gnc:commodity-amount->string .
|
||||
(define (gnc:make-exchange-function exchange-alist)
|
||||
(let ((exchangelist exchange-alist))
|
||||
(lambda (foreign-pair domestic)
|
||||
(cons domestic
|
||||
(cons
|
||||
(let ((pair (assoc (car foreign-pair) exchangelist)))
|
||||
(if (not pair)
|
||||
(gnc:numeric-zero)
|
||||
(gnc:numeric-mul (cadr foreign-pair) (cadr pair)
|
||||
;; FIXME: the constant 100 here is
|
||||
;; not a durable solution --
|
||||
;; anyone has a better idea?
|
||||
100 GNC-RND-ROUND)))
|
||||
'())))))
|
||||
|
||||
|
||||
;; Adds all different commodities in the commodity-collector <foreign>
|
||||
;; by using the exchange rates of <exchange-fn> to calculate the
|
||||
;; exchange rates to the commodity <domestic>. Returns the
|
||||
;; two-element-list with the domestic commodity and its corresponding
|
||||
;; balance, like (gnc:commodity* gnc:numeric).
|
||||
(define (gnc:sum-collector-commodity foreign domestic exchange-fn)
|
||||
(let ((balance (make-commodity-collector)))
|
||||
(foreign
|
||||
'format
|
||||
(lambda (curr val)
|
||||
(if (gnc:commodity-equiv? domestic curr)
|
||||
(balance 'add domestic val)
|
||||
(balance 'add domestic
|
||||
(cadr (exchange-fn (list curr val) domestic)))))
|
||||
#f)
|
||||
(balance 'getmonetary domestic #f)))
|
||||
|
||||
@ -0,0 +1,151 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; options-utilities.scm: Useful option helper functions.
|
||||
;;
|
||||
;; By Christian Stimming <stimming@tu-harburg.de>
|
||||
;;
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 2 of
|
||||
;; the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; if not, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(gnc:support "options-utilities.scm")
|
||||
|
||||
(gnc:depend "options.scm")
|
||||
|
||||
;; These are just a bunch of options which were useful in several
|
||||
;; reports and hence they got defined in a seperate function.
|
||||
|
||||
;; This is one single end-date of a report.
|
||||
(define (gnc:options-add-report-date!
|
||||
options pagename optname sort-tag)
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-date-option
|
||||
pagename optname
|
||||
sort-tag (_ "Select a date to report on")
|
||||
(lambda ()
|
||||
(cons 'absolute
|
||||
(gnc:timepair-end-day-time
|
||||
(gnc:secs->timepair
|
||||
(car (mktime (localtime (current-time))))))))
|
||||
#f 'absolute #f)))
|
||||
|
||||
;; This is a date-interval for a report.
|
||||
(define (gnc:options-add-date-interval!
|
||||
options pagename name-from name-to sort-tag)
|
||||
(begin
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-date-option
|
||||
pagename name-from
|
||||
(string-append sort-tag "a")
|
||||
(_ "Start of reporting period")
|
||||
(lambda ()
|
||||
(cons 'absolute
|
||||
(gnc:get-start-cal-year)))
|
||||
#f 'absolute #f))
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-date-option
|
||||
pagename name-to
|
||||
(string-append sort-tag "b")
|
||||
(_ "End of reporting period")
|
||||
(lambda ()
|
||||
(cons 'absolute
|
||||
(gnc:timepair-end-day-time
|
||||
(gnc:secs->timepair
|
||||
(car (mktime (localtime (current-time))))))))
|
||||
#f 'absolute #f))))
|
||||
|
||||
;; These help for selecting a bunch of accounts.
|
||||
(define (gnc:options-add-account-selection!
|
||||
options pagename
|
||||
name-display-depth name-show-subaccounts name-accounts
|
||||
sort-tag default-depth default-accounts)
|
||||
(begin
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-multichoice-option
|
||||
pagename name-display-depth
|
||||
(string-append sort-tag "a")
|
||||
(_ "Show accounts to this depth, overriding any other option.")
|
||||
default-depth
|
||||
(list (list->vector
|
||||
(list 'all (_ "All") (_ "Show all accounts")))
|
||||
(list->vector
|
||||
(list 1 "1" (_ "Top-level")))
|
||||
(list->vector
|
||||
(list 2 "2" (_ "Second-level")))
|
||||
(list->vector
|
||||
(list 3 "3" (_ "Third-level")))
|
||||
(list->vector
|
||||
(list 4 "4" (_ "Fourth-level")))
|
||||
(list->vector
|
||||
(list 5 "5" (_ "Fifth-level"))))))
|
||||
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-simple-boolean-option
|
||||
pagename name-show-subaccounts
|
||||
(string-append sort-tag "b")
|
||||
(_ "Override account-selection and show sub-accounts of all selected accounts?")
|
||||
#t))
|
||||
|
||||
;; Semantics of the account selection, as used in the
|
||||
;; gnc:html-build-acct-table: An account shows up if ( the
|
||||
;; tree-depth is large enough AND ( it is selected in the account
|
||||
;; selector OR ( always show sub-accounts is selected AND one of
|
||||
;; the parents is selected in the account selector. )))
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-account-list-option
|
||||
pagename name-accounts
|
||||
(string-append sort-tag "c")
|
||||
(_ "Report on these accounts, if display depth allows.")
|
||||
default-accounts
|
||||
#f #t))))
|
||||
|
||||
;; The single checkbox whether to include the sub-account balances
|
||||
;; into the other balances.
|
||||
(define (gnc:options-add-include-subaccounts!
|
||||
options pagename optname sort-tag)
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-simple-boolean-option
|
||||
pagename optname
|
||||
sort-tag (_ "Include sub-account balances in printed balance?") #t)))
|
||||
|
||||
;; These are common options for the selection of the report's
|
||||
;; currency/commodity.
|
||||
(define (gnc:options-add-currency-selection!
|
||||
options pagename
|
||||
name-show-foreign name-report-currency sort-tag)
|
||||
(begin
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-simple-boolean-option
|
||||
pagename name-show-foreign
|
||||
(string-append sort-tag "a")
|
||||
(_ "Display the account's foreign currency amount?") #f))
|
||||
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-currency-option
|
||||
pagename name-report-currency
|
||||
(string-append sort-tag "b")
|
||||
(_ "All other currencies will get converted to this currency.")
|
||||
(gnc:locale-default-currency)))))
|
||||
|
||||
Loading…
Reference in new issue