mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Christian Stimming's report patch.
* 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-97b8803252fd
This commit is contained in:
Dave Peticolas
parent
999ceb2a5d
commit
5dd4c94809
11
ChangeLog
11
ChangeLog
@ -1,3 +1,14 @@
|
||||
2001-02-09 Christian Stimming <stimming@tuhh.de>
|
||||
|
||||
* 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.
|
||||
|
||||
2001-02-08 Bill Gribble <grib@billgribble.com>
|
||||
|
||||
* src/gnome/druid-qif-import.c: restructure druid a bit to
|
||||
|
||||
@ -11,6 +11,7 @@ gnc_regular_scm_files = \
|
||||
command-line.scm \
|
||||
commodity-import.scm \
|
||||
commodity-table.scm \
|
||||
commodity-utilities.scm \
|
||||
config-var.scm \
|
||||
date-utilities.scm \
|
||||
depend.scm \
|
||||
@ -34,6 +35,7 @@ gnc_regular_scm_files = \
|
||||
iso-4217-currencies.scm \
|
||||
main.scm \
|
||||
options.scm \
|
||||
options-utilities.scm \
|
||||
path.scm \
|
||||
prefs.scm \
|
||||
report.scm \
|
||||
|
||||
299
src/scm/commodity-utilities.scm
Normal file
299
src/scm/commodity-utilities.scm
Normal file
@ -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)))
|
||||
|
||||
@ -24,6 +24,7 @@
|
||||
|
||||
(gnc:depend "report-utilities.scm")
|
||||
(gnc:depend "html-text.scm")
|
||||
(gnc:depend "commodity-utilities.scm")
|
||||
|
||||
;; returns a list with n #f (empty cell) values
|
||||
(define (gnc:html-make-empty-cells n)
|
||||
|
||||
151
src/scm/options-utilities.scm
Normal file
151
src/scm/options-utilities.scm
Normal file
@ -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)))))
|
||||
|
||||
@ -127,56 +127,6 @@
|
||||
(let ((group (gnc:account-get-children acct)))
|
||||
(gnc:group-get-subaccounts group)))
|
||||
|
||||
;; AFAIK the following stuff exists in SRFI. 02/01/2001
|
||||
;
|
||||
;;; returns a list contains elements of the-list for which predicate is true
|
||||
;(define (gnc:filter-list the-list predicate)
|
||||
; (let loop ((rest the-list)
|
||||
; (collected '()))
|
||||
; (cond ((null? rest) (reverse collected))
|
||||
; (else (loop (cdr rest)
|
||||
; (if (predicate (car rest))
|
||||
; (cons (car rest) collected)
|
||||
; collected))))))
|
||||
;
|
||||
;; like map, but restricted to one dimension, and
|
||||
;; guaranteed to have inorder semantics.
|
||||
;; note: map-in-order is in a SRFI.
|
||||
;(define (gnc:inorder-map the-list fn)
|
||||
; (let loop ((rest the-list)
|
||||
; (collected '()))
|
||||
; (cond ((null? rest) (reverse collected))
|
||||
; (else (loop (cdr rest)
|
||||
; (cons (fn (car rest)) collected))))))
|
||||
;
|
||||
;(define (gnc:for-loop thunk first last step)
|
||||
; (if (< first last)
|
||||
; (begin
|
||||
; (thunk first)
|
||||
; (gnc:for-loop thunk (+ first step) last step))
|
||||
; #f))
|
||||
;
|
||||
;(define (gnc:map-for thunk first last step)
|
||||
; (if (< first last)
|
||||
; (cons
|
||||
; (thunk first)
|
||||
; (gnc:map-for thunk (+ first step) last step))
|
||||
; '()))
|
||||
|
||||
;; The following tasks shall be done with the query-api. 02/01/2001
|
||||
;
|
||||
;;; applies thunk to each split in account account
|
||||
;(define (gnc:for-each-split-in-account account thunk)
|
||||
; (gnc:for-loop (lambda (x)
|
||||
; (thunk (gnc:account-get-split account x)))
|
||||
; 0 (gnc:account-get-split-count account) 1))
|
||||
;
|
||||
;;; applies thunk to each split in account account
|
||||
;(define (gnc:map-splits-in-account thunk account)
|
||||
; (gnc:map-for (lambda (x)
|
||||
; (thunk (gnc:account-get-split account x)))
|
||||
; 0 (gnc:account-get-split-count account) 1))
|
||||
|
||||
(define (gnc:transaction-map-splits thunk transaction)
|
||||
(let loop ((num-splits (gnc:transaction-get-split-count transaction))
|
||||
(i 0))
|
||||
@ -395,20 +345,6 @@
|
||||
('list commoditylist) ; this one is only for internal use
|
||||
(else (gnc:warn "bad commodity-collector action: " action))))))
|
||||
|
||||
;; Nobody uses the following functions. 02/01/2001
|
||||
;;; Add x to list lst if it is not already in there
|
||||
;(define (addunique lst x)
|
||||
; (if (null? lst)
|
||||
; (list x) ; all checked add it
|
||||
; (if (equal? x (car lst))
|
||||
; lst ; found, quit search and don't add again
|
||||
; (cons (car lst) (addunique (cdr lst) x))))) ; keep searching
|
||||
;
|
||||
;;; get transaction date from split - needs to be done indirectly
|
||||
;;; as it's stored in the parent transaction
|
||||
;(define (gnc:split-get-transaction-date split)
|
||||
; (gnc:transaction-get-date-posted (gnc:split-get-parent split)))
|
||||
|
||||
;; get the account balance at the specified date. if include-children?
|
||||
;; is true, the balances of all children (not just direct children)
|
||||
;; are included in the calculation.
|
||||
@ -555,405 +491,3 @@
|
||||
(if (equal? (car splits) split)
|
||||
(loop (cdr splits))
|
||||
(cons (car splits) (loop (cdr splits)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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))))
|
||||
(query (gnc:malloc-query))
|
||||
(splits #f)
|
||||
;; sumlist: a multilevel association list. 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 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 value-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 '()))))
|
||||
|
||||
(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)
|
||||
0 GNC-DENOM-REDUCE)
|
||||
((caadr known-pair) 'total #f)
|
||||
0 GNC-DENOM-REDUCE))
|
||||
;; in other words: (/ (* (caadr c) (cdadr pair-b)) (caadr
|
||||
;; pair-b) ))
|
||||
(cons a b)))
|
||||
|
||||
(if (not (null? curr-accounts))
|
||||
(begin
|
||||
(gnc:query-set-group query (gnc:get-current-group))
|
||||
(gnc:query-add-account-match
|
||||
query (gnc:list->glist curr-accounts)
|
||||
'acct-match-any 'query-and)
|
||||
(gnc:query-add-date-match-timepair
|
||||
query #f end-date #t end-date '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)
|
||||
|
||||
; (warn "report-commodity is "
|
||||
; (gnc:commodity-value->string
|
||||
; (list report-commodity (gnc:numeric-zero)))
|
||||
; report-commodity)
|
||||
|
||||
;; Now 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)
|
||||
(begin
|
||||
; (warn "not found "
|
||||
; (gnc:commodity-value->string
|
||||
; (list account-comm share-amount))
|
||||
; ", trying "
|
||||
; (gnc:commodity-value->string
|
||||
; (list transaction-comm value-amount))
|
||||
; sumlist)
|
||||
(assoc account-comm sumlist))
|
||||
tmp)))
|
||||
; (if comm-list
|
||||
; (warn "looking for toplevel comm: "
|
||||
; (gnc:commodity-value->string
|
||||
; (list (car comm-list) (gnc:numeric-zero))))
|
||||
; (warn "not comm-list"))
|
||||
|
||||
|
||||
;; 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)))))
|
||||
; (warn "XX " (gnc:commodity-value->string
|
||||
; (list transaction-comm value-amount))
|
||||
; (gnc:commodity-value->string
|
||||
; (list account-comm share-amount)))
|
||||
((caadr pair) 'add value-amount)
|
||||
((cdadr pair) 'add share-amount)
|
||||
(set! comm-list (list account-comm (list pair)))
|
||||
(set! sumlist (cons comm-list sumlist)))
|
||||
;; yes, check for second currency.
|
||||
(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))))
|
||||
; (warn "current transaction "
|
||||
; (gnc:commodity-value->string
|
||||
; (list (car foreignlist) (cadr foreignlist)))
|
||||
; (gnc:commodity-value->string
|
||||
; (list (car comm-list) (caddr foreignlist))))
|
||||
;; if not, create a new entry in comm-list.
|
||||
(if (not pair)
|
||||
(begin
|
||||
;;(warn "ZZ ")
|
||||
(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)))))
|
||||
;;(display (gnc:commodity-value->string (list (car
|
||||
;;foreignlist) (cadr foreignlist)))
|
||||
;;(gnc:commodity-value->string (list report-commodity
|
||||
;;(caddr foreignlist)))))))
|
||||
((caadr pair) 'add (cadr foreignlist))
|
||||
;;(warn "ZZ6 " sumlist)
|
||||
((cdadr pair) 'add (caddr foreignlist))))))
|
||||
splits)))
|
||||
|
||||
;; Now go through all additional toplevel non-report-commodity
|
||||
;; balances and add them to report-commodity, if possible.
|
||||
(let ((reportlist (cadr (assoc report-commodity sumlist))))
|
||||
(for-each
|
||||
(lambda (l)
|
||||
(if (not (gnc:commodity-equiv? (car l) report-commodity))
|
||||
(for-each
|
||||
(lambda (c)
|
||||
(let ((pair-a (assoc (car l) reportlist))
|
||||
(pair-b (assoc (car c) reportlist))
|
||||
(rate (gnc:numeric-zero)))
|
||||
(if (and (not pair-a) (not pair-b))
|
||||
(warn "can't calculate rate for"
|
||||
(gnc:commodity-value->string
|
||||
(list (car c) (caadr c)))
|
||||
" = "
|
||||
(gnc:commodity-value->string
|
||||
(list (car l) (cdadr c)))
|
||||
" to "
|
||||
(gnc:commodity-value->string
|
||||
(list report-commodity (gnc:numeric-zero))))
|
||||
(if (and pair-a pair-b)
|
||||
(warn "Oops - what went wrong? Both are found:"
|
||||
(gnc:commodity-value->string
|
||||
(list (car c) (caadr c)))
|
||||
" = "
|
||||
(gnc:commodity-value->string
|
||||
(list (car l) (cdadr c))))
|
||||
(let
|
||||
((newrate
|
||||
(if (not pair-a)
|
||||
(list (car l)
|
||||
(make-newrate (cdadr c)
|
||||
(caadr c) pair-b))
|
||||
(list (car c)
|
||||
(make-newrate (caadr c)
|
||||
(cdadr c) 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 l))))
|
||||
sumlist)
|
||||
|
||||
reportlist)))
|
||||
|
||||
;; 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)
|
||||
(begin
|
||||
;;(display (gnc:commodity-value->string (list (car e) ((caadr
|
||||
;;e) 'total #f))) (gnc:commodity-value->string (list
|
||||
;;report-commodity ((cdadr e) 'total #f))))
|
||||
; (warn "rate"
|
||||
; (gnc:commodity-value->string
|
||||
; (list (car e)
|
||||
; ((caadr e) 'total #f)))
|
||||
; " = "
|
||||
; (gnc:commodity-value->string
|
||||
; (list report-commodity
|
||||
; ((cdadr e) 'total #f))))
|
||||
|
||||
(list (car e)
|
||||
(gnc:numeric-abs
|
||||
(gnc:numeric-div ((cdadr e) 'total #f)
|
||||
((caadr e) 'total #f)
|
||||
;; 0 stands for GNC_DENOM_AUTO
|
||||
0
|
||||
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
|
||||
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)))
|
||||
|
||||
|
||||
;; 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)))))
|
||||
|
||||
|
||||
@ -1,6 +1,10 @@
|
||||
;; Index file to load all of the releavant reports.
|
||||
(gnc:support "report/report-list.scm")
|
||||
|
||||
;; Helper functions for reports (which haven't been included
|
||||
;; elsewhere)
|
||||
(gnc:depend "options-utilities.scm")
|
||||
|
||||
;; reports
|
||||
(gnc:depend "report/account-summary.scm")
|
||||
(gnc:depend "report/average-balance.scm")
|
||||
@ -10,7 +14,3 @@
|
||||
;; style sheets
|
||||
(gnc:depend "report/stylesheet-plain.scm")
|
||||
(gnc:depend "report/stylesheet-fancy.scm")
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user