"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "gnucash/report/report-utilities.scm" between
gnucash-5.0.tar.bz2 and gnucash-5.1.tar.bz2

About: GnuCash is personal and small-business financial-accounting software.

report-utilities.scm  (gnucash-5.0.tar.bz2)	:	report-utilities.scm  (gnucash-5.1.tar.bz2)
skipping to change at line 164		skipping to change at line 164
;; True if the account is of type income or expense		;; True if the account is of type income or expense
(define (gnc:account-is-inc-exp? account)		(define (gnc:account-is-inc-exp? account)
(let ((type (xaccAccountGetType account)))		(let ((type (xaccAccountGetType account)))
(member type (list ACCT-TYPE-INCOME ACCT-TYPE-EXPENSE))))		(member type (list ACCT-TYPE-INCOME ACCT-TYPE-EXPENSE))))
;; Returns only those accounts out of the list <accounts> which have		;; Returns only those accounts out of the list <accounts> which have
;; one of the type identifiers in typelist.		;; one of the type identifiers in typelist.
(define (gnc:filter-accountlist-type typelist accounts)		(define (gnc:filter-accountlist-type typelist accounts)
(filter (lambda (a)		(filter (lambda (a)
(and (not (null? a)) (member (xaccAccountGetType a) typelist)))		(and (not (null? a)) (member (xaccAccountGetType a) typelist)))
accounts))		accounts))
;; Decompose a given list of accounts 'accounts' into an alist		;; Decompose a given list of accounts 'accounts' into an alist
;; according to their types. Each element of alist is a list, whose		;; according to their types. Each element of alist is a list, whose
;; first element is the type, e.g. ACCT-TYPE-ASSET, and the rest (cdr)		;; first element is the type, e.g. ACCT-TYPE-ASSET, and the rest (cdr)
;; of the element is the list of accounts which belong to that		;; of the element is the list of accounts which belong to that
;; category.		;; category.
(define (gnc:decompose-accountlist accounts)		(define (gnc:decompose-accountlist accounts)
(map (lambda (x) (cons		(map (lambda (x) (cons
(car x)		(car x)
(gnc:filter-accountlist-type (cdr x) accounts)))		(gnc:filter-accountlist-type (cdr x) accounts)))
(list		(list
(cons ACCT-TYPE-ASSET		(cons ACCT-TYPE-ASSET
(list ACCT-TYPE-ASSET ACCT-TYPE-BANK ACCT-TYPE-CASH		(list ACCT-TYPE-ASSET ACCT-TYPE-BANK ACCT-TYPE-CASH
ACCT-TYPE-CHECKING ACCT-TYPE-SAVINGS		ACCT-TYPE-CHECKING ACCT-TYPE-SAVINGS
ACCT-TYPE-MONEYMRKT ACCT-TYPE-RECEIVABLE		ACCT-TYPE-MONEYMRKT ACCT-TYPE-RECEIVABLE
ACCT-TYPE-STOCK ACCT-TYPE-MUTUAL		ACCT-TYPE-STOCK ACCT-TYPE-MUTUAL
ACCT-TYPE-CURRENCY))		ACCT-TYPE-CURRENCY))
(cons ACCT-TYPE-LIABILITY		(cons ACCT-TYPE-LIABILITY
(list ACCT-TYPE-LIABILITY ACCT-TYPE-PAYABLE ACCT-TYPE-CREDIT		(list ACCT-TYPE-LIABILITY ACCT-TYPE-PAYABLE ACCT-TYPE-CREDIT
ACCT-TYPE-CREDITLINE))		ACCT-TYPE-CREDITLINE))
(cons ACCT-TYPE-EQUITY (list ACCT-TYPE-EQUITY))		(cons ACCT-TYPE-EQUITY (list ACCT-TYPE-EQUITY))
(cons ACCT-TYPE-INCOME (list ACCT-TYPE-INCOME))		(cons ACCT-TYPE-INCOME (list ACCT-TYPE-INCOME))
(cons ACCT-TYPE-EXPENSE (list ACCT-TYPE-EXPENSE))		(cons ACCT-TYPE-EXPENSE (list ACCT-TYPE-EXPENSE))
(cons ACCT-TYPE-TRADING (list ACCT-TYPE-TRADING)))))		(cons ACCT-TYPE-TRADING (list ACCT-TYPE-TRADING)))))
;; Returns the name of the account type as a string, and in its plural		;; Returns the name of the account type as a string, and in its plural
;; form (as opposed to xaccAccountGetTypeStr which gives the		;; form (as opposed to xaccAccountGetTypeStr which gives the
;; singular form of the word).		;; singular form of the word).
(define (gnc:account-get-type-string-plural type)		(define (gnc:account-get-type-string-plural type)
(assoc-ref		(assoc-ref
(list		(list
(cons ACCT-TYPE-BANK (G_ "Bank"))		(cons ACCT-TYPE-BANK (G_ "Bank"))
(cons ACCT-TYPE-CASH (G_ "Cash"))		(cons ACCT-TYPE-CASH (G_ "Cash"))
(cons ACCT-TYPE-CREDIT (G_ "Credits"))		(cons ACCT-TYPE-CREDIT (G_ "Credits"))
skipping to change at line 221		skipping to change at line 221
(cons ACCT-TYPE-RECEIVABLE (G_ "Accounts Receivable"))		(cons ACCT-TYPE-RECEIVABLE (G_ "Accounts Receivable"))
(cons ACCT-TYPE-PAYABLE (G_ "Accounts Payable"))		(cons ACCT-TYPE-PAYABLE (G_ "Accounts Payable"))
(cons ACCT-TYPE-CREDITLINE (G_ "Credit Lines"))		(cons ACCT-TYPE-CREDITLINE (G_ "Credit Lines"))
(cons ACCT-TYPE-TRADING (G_ "Trading Accounts")))		(cons ACCT-TYPE-TRADING (G_ "Trading Accounts")))
type))		type))
;; Get the list of all different commodities that are used within the		;; Get the list of all different commodities that are used within the
;; 'accounts', excluding the 'exclude-commodity'.		;; 'accounts', excluding the 'exclude-commodity'.
(define (gnc:accounts-get-commodities accounts exclude-commodity)		(define (gnc:accounts-get-commodities accounts exclude-commodity)
(delete exclude-commodity		(delete exclude-commodity
(sort-and-delete-duplicates		(sort-and-delete-duplicates
(map xaccAccountGetCommodity accounts)		(map xaccAccountGetCommodity accounts)
(lambda (a b)		(lambda (a b)
(gnc:string-locale<? (gnc-commodity-get-unique-name a)		(gnc:string-locale<? (gnc-commodity-get-unique-name a)
(gnc-commodity-get-unique-name b)))		(gnc-commodity-get-unique-name b)))
gnc-commodity-equiv)))		gnc-commodity-equiv)))
;; Returns the depth of the current account hierarchy, that is, the		;; Returns the depth of the current account hierarchy, that is, the
;; maximum level of subaccounts in the tree		;; maximum level of subaccounts in the tree
(define (gnc:get-current-account-tree-depth)		(define (gnc:get-current-account-tree-depth)
(let ((root (gnc-get-current-root-account)))		(let ((root (gnc-get-current-root-account)))
skipping to change at line 268		skipping to change at line 268
;; would break existing code, so if I would go for speed optimization		;; would break existing code, so if I would go for speed optimization
;; I might just go for the record-and-function-set way. <rlb> cstim:		;; I might just go for the record-and-function-set way. <rlb> cstim:
;; yes. I think that would still be faster.		;; yes. I think that would still be faster.
;; This is a collector of values -- works similar to the stats-collector but		;; This is a collector of values -- works similar to the stats-collector but
;; has much less overhead. It is used by the currency-collector (see below).		;; has much less overhead. It is used by the currency-collector (see below).
(define (gnc:make-value-collector)		(define (gnc:make-value-collector)
(let ((value 0))		(let ((value 0))
(lambda (action amount)		(lambda (action amount)
(case action		(case action
((add) (if (number? amount)		((add) (if (number? amount)
(set! value (+ amount value))))		(set! value (+ amount value))))
((total) value)		((total) value)
(else (gnc:warn "bad value-collector action: " action))))))		(else (gnc:warn "bad value-collector action: " action))))))
;; A commodity collector. This is intended to handle multiple		;; A commodity collector. This is intended to handle multiple
;; currencies' amounts. The amounts are accumulated via 'add, the		;; currencies' amounts. The amounts are accumulated via 'add, the
;; result can be fetched via 'format. This used to work with strings		;; result can be fetched via 'format. This used to work with strings
;; as currencies and doubles as values, but now it uses		;; as currencies and doubles as values, but now it uses
;; <gnc:commodity*> as commodity and <gnc:numeric> as value.		;; <gnc:commodity*> as commodity and <gnc:numeric> as value.
;;		;;
;; Old Example: (define a (make-commodity-collector)) ... (a 'add 'USD		;; Old Example: (define a (make-commodity-collector)) ... (a 'add 'USD
;; 12) ... (a 'format (lambda(x y)(list x y)) #f) used to give you		;; 12) ... (a 'format (lambda(x y)(list x y)) #f) used to give you
;; something like ((USD 123.4) (DEM 12.21) (FRF -23.32))		;; something like ((USD 123.4) (DEM 12.21) (FRF -23.32))
skipping to change at line 323		skipping to change at line 323
;; (cons commodity numeric-collector)		;; (cons commodity numeric-collector)
(define (gnc:make-commodity-collector)		(define (gnc:make-commodity-collector)
;; the association list of (commodity . value-collector) pairs.		;; the association list of (commodity . value-collector) pairs.
(let ((commoditylist '()))		(let ((commoditylist '()))
;; helper function to add a (commodity . value) pair to our list.		;; helper function to add a (commodity . value) pair to our list.
;; If no pair with this commodity exists, we will create one.		;; If no pair with this commodity exists, we will create one.
(define (add-commodity-value commodity value)		(define (add-commodity-value commodity value)
(let ((pair (assoc commodity commoditylist)))		(let ((pair (assoc commodity commoditylist)))
(unless pair		(unless pair
(set! pair (list commodity (gnc:make-value-collector)))		(set! pair (list commodity (gnc:make-value-collector)))
(set! commoditylist (cons pair commoditylist)))		(set! commoditylist (cons pair commoditylist)))
((cadr pair) 'add value)))		((cadr pair) 'add value)))
;; helper function to walk an association list, adding each		;; helper function to walk an association list, adding each
;; (commodity . collector) pair to our list at the appropriate		;; (commodity . collector) pair to our list at the appropriate
;; place		;; place
(define (add-commodity-clist clist)		(define (add-commodity-clist clist)
(cond ((null? clist) '())		(cond ((null? clist) '())
(else (add-commodity-value		(else (add-commodity-value
(caar clist)		(caar clist)
((cadar clist) 'total #f))		((cadar clist) 'total #f))
(add-commodity-clist (cdr clist)))))		(add-commodity-clist (cdr clist)))))
(define (minus-commodity-clist clist)		(define (minus-commodity-clist clist)
(cond ((null? clist) '())		(cond ((null? clist) '())
(else (add-commodity-value		(else (add-commodity-value
(caar clist)		(caar clist)
(- ((cadar clist) 'total #f)))		(- ((cadar clist) 'total #f)))
(minus-commodity-clist (cdr clist)))))		(minus-commodity-clist (cdr clist)))))
;; helper function walk the association list doing a callback on		;; helper function walk the association list doing a callback on
;; each key-value pair.		;; each key-value pair.
(define (process-commodity-list fn clist)		(define (process-commodity-list fn clist)
(map		(map
(lambda (pair)		(lambda (pair)
(fn (car pair) ((cadr pair) 'total #f)))		(fn (car pair) ((cadr pair) 'total #f)))
clist))		clist))
;; helper function which is given a commodity and returns a list		;; helper function which is given a commodity and returns a list
;; (list gnc:commodity number).		;; (list gnc:commodity number).
(define (getpair c sign?)		(define (getpair c sign?)
(let* ((pair (assoc c commoditylist))		(let* ((pair (assoc c commoditylist))
(total (if pair ((cadr pair) 'total #f) 0)))		(total (if pair ((cadr pair) 'total #f) 0)))
(list c (if sign? (- total) total))))		(list c (if sign? (- total) total))))
;; helper function which is given a commodity and returns a		;; helper function which is given a commodity and returns a
;; <gnc:monetary> value, whose amount may be 0.		;; <gnc:monetary> value, whose amount may be 0.
(define (getmonetary c sign?)		(define (getmonetary c sign?)
(let* ((pair (assoc c commoditylist))		(let* ((pair (assoc c commoditylist))
(total (if pair ((cadr pair) 'total #f) 0)))		(total (if pair ((cadr pair) 'total #f) 0)))
(gnc:make-gnc-monetary c (if sign? (- total) total))))		(gnc:make-gnc-monetary c (if sign? (- total) total))))
		(define (not-zero? l) (not (zero? ((cadr l) 'total #f))))
;; Dispatch function		;; Dispatch function
(lambda (action commodity amount)		(lambda (action commodity amount)
(case action		(case action
((add) (add-commodity-value commodity amount))		((add) (add-commodity-value commodity amount))
((merge) (add-commodity-clist		((merge) (add-commodity-clist
(commodity 'list #f #f)))		(commodity 'list #f #f)))
((minusmerge) (minus-commodity-clist		((minusmerge) (minus-commodity-clist
(commodity 'list #f #f)))		(commodity 'list #f #f)))
((format) (process-commodity-list commodity commoditylist))		((format) (process-commodity-list commodity commoditylist))
((reset) (set! commoditylist '()))		((reset) (set! commoditylist '()))
((getpair) (getpair commodity amount))		((getpair) (getpair commodity amount))
((getmonetary) (getmonetary commodity amount))		((getmonetary) (getmonetary commodity amount))
((list) commoditylist) ; this one is only for internal use		((remove-zeros) (set! commoditylist (filter not-zero? commoditylist)))
(else (gnc:warn "bad commodity-collector action: " action))))))		((list) commoditylist) ; this one is only for internal use
		(else (gnc:warn "bad commodity-collector action: " action))))))
(define (gnc:commodity-collector-get-negated collector)		(define (gnc:commodity-collector-get-negated collector)
(let ((negated (gnc:make-commodity-collector)))		(let ((negated (gnc:make-commodity-collector)))
(negated 'minusmerge collector #f)		(negated 'minusmerge collector #f)
negated))		negated))
;; Returns zero if all entries in this collector are zero.		;; Returns zero if all entries in this collector are zero.
(define (gnc-commodity-collector-allzero? collector)		(define (gnc-commodity-collector-allzero? collector)
(every zero? (map cdr (collector 'format cons #f))))		(every zero? (map cdr (collector 'format cons #f))))
skipping to change at line 577		skipping to change at line 580
;; commodity collector.		;; commodity collector.
(define (gnc:account-get-comm-value-at-date account date include-children?)		(define (gnc:account-get-comm-value-at-date account date include-children?)
(gnc:account-get-comm-value-interval account #f date include-children?))		(gnc:account-get-comm-value-interval account #f date include-children?))
;; Adds all accounts' balances, where the balances are determined with		;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. The reverse-balance-fn		;; the get-balance-fn. The reverse-balance-fn
;; (e.g. gnc-reverse-balance) should return #t if the		;; (e.g. gnc-reverse-balance) should return #t if the
;; account's balance sign should get reversed. Returns a		;; account's balance sign should get reversed. Returns a
;; commodity-collector.		;; commodity-collector.
(define (gnc:accounts-get-balance-helper		(define (gnc:accounts-get-balance-helper
accounts get-balance-fn reverse-balance-fn)		accounts get-balance-fn reverse-balance-fn)
(let ((collector (gnc:make-commodity-collector)))		(let ((collector (gnc:make-commodity-collector)))
(for-each		(for-each
(lambda (acct)		(lambda (acct)
(collector		(collector
(if (reverse-balance-fn acct) 'minusmerge 'merge)		(if (reverse-balance-fn acct) 'minusmerge 'merge)
(get-balance-fn acct)		(get-balance-fn acct)
#f))		#f))
accounts)		accounts)
collector))		collector))
;; Adds all accounts' balances, where the balances are determined with		;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. Intended for usage with a balance sheet, hence		;; the get-balance-fn. Intended for usage with a balance sheet, hence
;; a) the income/expense accounts are ignored, and b) no signs are		;; a) the income/expense accounts are ignored, and b) no signs are
;; reversed at all. Returns a commodity-collector.		;; reversed at all. Returns a commodity-collector.
(define (gnc:accounts-get-comm-total-assets accounts		(define (gnc:accounts-get-comm-total-assets accounts
get-balance-fn)		get-balance-fn)
(gnc:accounts-get-balance-helper		(gnc:accounts-get-balance-helper
(filter (lambda (a) (not (gnc:account-is-inc-exp? a)))		(filter (lambda (a) (not (gnc:account-is-inc-exp? a)))
accounts)		accounts)
get-balance-fn		get-balance-fn
(lambda(x) #f)))		(lambda(x) #f)))
;; get the change in balance from the 'from' date to the 'to' date.		;; get the change in balance from the 'from' date to the 'to' date.
;; this isn't quite as efficient as it could be, but it's a whole lot		;; this isn't quite as efficient as it could be, but it's a whole lot
;; simpler :)		;; simpler :)
(define (gnc:account-get-balance-interval account from to include-children?)		(define (gnc:account-get-balance-interval account from to include-children?)
(let ((collector (gnc:account-get-comm-balance-interval		(let ((collector (gnc:account-get-comm-balance-interval
account from to include-children?)))		account from to include-children?)))
(cadr (collector 'getpair (xaccAccountGetCommodity account) #f))))		(cadr (collector 'getpair (xaccAccountGetCommodity account) #f))))
skipping to change at line 636		skipping to change at line 639
(define (gnc:accountlist-get-comm-balance-at-date-with-closing accountlist date)		(define (gnc:accountlist-get-comm-balance-at-date-with-closing accountlist date)
(gnc:account-get-trans-type-balance-interval-with-closing accountlist #f #f da te))		(gnc:account-get-trans-type-balance-interval-with-closing accountlist #f #f da te))
(define (gnc:split-voided? split)		(define (gnc:split-voided? split)
(let ((trans (xaccSplitGetParent split)))		(let ((trans (xaccSplitGetParent split)))
(xaccTransGetVoidStatus trans)))		(xaccTransGetVoidStatus trans)))
(define (gnc:report-starting report-name)		(define (gnc:report-starting report-name)
(gnc-window-show-progress (format #f		(gnc-window-show-progress (format #f
(G_ "Building '~a' report …")		(G_ "Building '~a' report …")
(G_ report-name))		(G_ report-name))
0))		0))
(define (gnc:report-render-starting report-name)		(define (gnc:report-render-starting report-name)
(gnc-window-show-progress (format #f		(gnc-window-show-progress (format #f
(G_ "Rendering '~a' report …")		(G_ "Rendering '~a' report …")
(if (string-null? report-name)		(if (string-null? report-name)
(G_ "Untitled")		(G_ "Untitled")
(G_ report-name)))		(G_ report-name)))
0))		0))
(define (gnc:report-percent-done percent)		(define (gnc:report-percent-done percent)
(if (> percent 100)		(if (> percent 100)
(gnc:warn "report more than 100% finished. " percent))		(gnc:warn "report more than 100% finished. " percent))
(gnc-window-show-progress "" percent))		(gnc-window-show-progress "" percent))
(define-public gnc:pulse-progress-bar		(define-public gnc:pulse-progress-bar
(let ((pulse-idx 0))		(let ((pulse-idx 0))
(lambda ()		(lambda ()
(set! pulse-idx (1+ pulse-idx))		(set! pulse-idx (1+ pulse-idx))
End of changes. 21 change blocks.
49 lines changed or deleted		52 lines changed or added

---