IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

Christian Stimming's report patch.

Browse Source 
* 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 2001-02-09 22:07:16 +00:00
parent 999ceb2a5d
commit 5dd4c94809
7 changed files with 468 additions and 470 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
ChangeLog
View File

@ -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

2
src/scm/Makefile.am
View File

@ -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
View 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)))

1
src/scm/html-utilities.scm
View File

@ -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
View 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)))))

466
src/scm/report-utilities.scm
View File

@ -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)))))

8
src/scm/report/report-list.scm
View File

@ -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")