gnucash maint: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Wed Sep 11 08:38:46 EDT 2019
Updated via https://github.com/Gnucash/gnucash/commit/23d0fa13 (commit)
via https://github.com/Gnucash/gnucash/commit/7a36c229 (commit)
via https://github.com/Gnucash/gnucash/commit/70cb3a0b (commit)
via https://github.com/Gnucash/gnucash/commit/ff8c5725 (commit)
via https://github.com/Gnucash/gnucash/commit/b05c57a9 (commit)
from https://github.com/Gnucash/gnucash/commit/d3f86d2a (commit)
commit 23d0fa132414faab93acb46214c7c6197938044e
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Sep 8 23:37:10 2019 +0800
[balsheet-pnl] bugfix last pnl period must not be decreased by 1 day
logic error to calculate last period date pair for col-header.
pnl report-dates are stored as a list of time64. consider a regular
profit&loss for "quarterly income & expense amounts for last
calendar year". dates are 1-jan to 31-dec. the report-dates are
'(1-jan 1-apr 1-jul 1-oct 31-dec). the inc/exp accounts balances are
queried for the above dates, and the delta change (sans closing
entries) constitutes the desired answer.
the col-header needs to report "1-jan to 31-mar", which it does by
retrieving 2 consecutive dates in the list (1-jan 1-apr), then
decrease second date by 1 day to obtain "1-jan to 31-mar" . however
this fails for the last period which would return '1-oct to 30-dec'.
this commit changes display for last period to return last report-date
so that the header is fixed to '1-oct to 31-dec'.
this is cosmetic for header dates only, calculations of periodic
income/expense amounts were never affected and included entries on the
last report-date (e.g. 31-dec as above).
diff --git a/gnucash/report/standard-reports/balsheet-pnl.scm b/gnucash/report/standard-reports/balsheet-pnl.scm
index 2a4d511b4..76a878228 100644
--- a/gnucash/report/standard-reports/balsheet-pnl.scm
+++ b/gnucash/report/standard-reports/balsheet-pnl.scm
@@ -1081,14 +1081,17 @@ also show overall period profit & loss."))
(closing-regexp (get-option pagename-entries optname-closing-regexp))
(include-overall-period? (get-option gnc:pagename-general
optname-include-overall-period))
- (col-idx->datepair (lambda (idx)
- (if (eq? idx 'overall-period)
- (cons (car report-dates) (last report-dates))
- (cons (list-ref report-dates idx)
- (gnc:time64-end-day-time
- (decdate
- (list-ref report-dates (1+ idx))
- DayDelta))))))
+ (col-idx->datepair
+ (lambda (idx)
+ (cond
+ ((eq? idx 'overall-period)
+ (cons (car report-dates) (last report-dates)))
+ ((= idx (- (length report-dates) 2))
+ (cons (list-ref report-dates idx) (last report-dates)))
+ (else
+ (cons (list-ref report-dates idx)
+ (decdate (list-ref report-dates (1+ idx)) DayDelta))))))
+
(col-idx->monetarypair (lambda (balancelist idx)
(if (eq? idx 'overall-period)
(cons (car balancelist) (last balancelist))
commit 7a36c229c54a54d27444a30be44cae3622681a99
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Sep 8 20:39:09 2019 +0800
[balsheet-pnl] speed up by pre-appending accounts
minor efficiency change. append-reverse is faster than append, and
storing the appended lists is rather convenient for this
report which uses them a lot.
diff --git a/gnucash/report/standard-reports/balsheet-pnl.scm b/gnucash/report/standard-reports/balsheet-pnl.scm
index 8e9afe25e..2a4d511b4 100644
--- a/gnucash/report/standard-reports/balsheet-pnl.scm
+++ b/gnucash/report/standard-reports/balsheet-pnl.scm
@@ -546,7 +546,7 @@ also show overall period profit & loss."))
monetary)))
(loop (cdr accounts)
(if (list? amt)
- (append amt result)
+ (append-reverse amt result)
(cons amt result))))))))
(define (is-not-zero? accts)
@@ -866,6 +866,10 @@ also show overall period profit & loss."))
(assoc-ref split-up-accounts ACCT-TYPE-EQUITY))
(trading-accounts
(assoc-ref split-up-accounts ACCT-TYPE-TRADING))
+
+ (asset-liability (append-reverse asset-accounts liability-accounts))
+ (income-expense (append-reverse income-accounts expense-accounts))
+
(doc (gnc:make-html-document))
(multicol-table-left (gnc:make-html-table))
(multicol-table-right (if enable-dual-columns?
@@ -915,8 +919,7 @@ also show overall period profit & loss."))
(let ((asset-liab-balances
(map cdr (filter
(lambda (acc-balances)
- (member (car acc-balances)
- (append asset-accounts liability-accounts)))
+ (member (car acc-balances) asset-liability))
accounts-balances))))
(if (null? asset-liab-balances)
(map (const (gnc:make-commodity-collector)) report-dates)
@@ -927,8 +930,7 @@ also show overall period profit & loss."))
(map cdr
(filter
(lambda (acc-balances)
- (member (car acc-balances)
- (append income-accounts expense-accounts)))
+ (member (car acc-balances) income-expense))
accounts-balances))))
(if (null? inc-exp-balances)
(map (const (gnc:make-commodity-collector)) report-dates)
@@ -956,7 +958,7 @@ also show overall period profit & loss."))
(list-ref asset-liability-balances col-idx))
(asset-liability-basis
(gnc:accounts-get-comm-total-assets
- (append asset-accounts liability-accounts)
+ asset-liability
(lambda (acc)
(gnc:account-get-comm-value-at-date acc date #f))))
(unrealized (gnc:make-commodity-collector)))
@@ -973,9 +975,7 @@ also show overall period profit & loss."))
(list-ref income-expense-balances col-idx)))
(if (and common-currency
(every has-price?
- (map xaccAccountGetCommodity
- (append income-accounts
- expense-accounts))))
+ (gnc:accounts-get-commodities income-expense #f)))
(gnc:monetary-neg
(monetaries->exchanged income-expense-balance
common-currency price-source date))
@@ -992,8 +992,7 @@ also show overall period profit & loss."))
(list "General" "Step Size" incr)
(list "General" "Price Source"
(or price-source 'pricedb-nearest))
- (list "Accounts" "Accounts"
- (append asset-accounts liability-accounts))))))
+ (list "Accounts" "Accounts" asset-liability)))))
(get-col-header-fn (lambda (accounts col-idx)
(let* ((date (list-ref report-dates col-idx))
(header (qof-print-date date))
@@ -1065,7 +1064,7 @@ also show overall period profit & loss."))
(if (and common-currency show-rates?)
(add-to-table multicol-table-right (_ "Exchange Rates")
- (append asset-accounts liability-accounts)
+ asset-liability
#:get-col-header-fn get-exchange-rates-fn
#:show-accounts? #f
#:show-total? #f))
@@ -1098,7 +1097,7 @@ also show overall period profit & loss."))
(closing-entries (let ((query (qof-query-create-for-splits)))
(qof-query-set-book query (gnc-get-current-book))
(xaccQueryAddAccountMatch
- query (append income-accounts expense-accounts)
+ query income-expense
QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(if (and closing-str (not (string-null? closing-str)))
(xaccQueryAddDescriptionMatch
@@ -1166,8 +1165,7 @@ also show overall period profit & loss."))
(list "General" "Step Size" (or incr 'MonthDelta))
(list "General" "Price Source"
(or price-source 'pricedb-nearest))
- (list "Accounts" "Accounts"
- (append income-accounts expense-accounts))))))
+ (list "Accounts" "Accounts" income-expense)))))
(get-col-header-fn
(lambda (accounts col-idx)
(let* ((datepair (col-idx->datepair col-idx))
@@ -1236,14 +1234,14 @@ also show overall period profit & loss."))
(unless (or (null? income-accounts)
(null? expense-accounts))
(add-to-table multicol-table-left (_ "Net Income")
- (append income-accounts expense-accounts)
+ income-expense
#:show-accounts? #f
#:negate-amounts? #t
#:force-total? #t))
(if (and common-currency show-rates?)
(add-to-table multicol-table-left (_ "Exchange Rates")
- (append income-accounts expense-accounts)
+ income-expense
#:get-col-header-fn get-exchange-rates-fn
#:show-accounts? #f
#:show-total? #f))
commit 70cb3a0b979991cc34a00278d9de246ad5fac1c5
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Sep 10 00:34:25 2019 +0800
[utilities] compact sort-and-delete-duplicates
This is still readable IMHO. kons is the result constructor, and adds
item to result iff different from previous add.
diff --git a/libgnucash/scm/utilities.scm b/libgnucash/scm/utilities.scm
index 105f49341..aa69e277f 100644
--- a/libgnucash/scm/utilities.scm
+++ b/libgnucash/scm/utilities.scm
@@ -188,12 +188,8 @@
;; uses quicksort internally.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define* (sort-and-delete-duplicates lst < #:optional (= =))
- (let lp ((lst (sort lst <)) (result '()))
- (cond
- ((null? lst) '())
- ((null? (cdr lst)) (reverse (cons (car lst) result)))
- ((= (car lst) (cadr lst)) (lp (cdr lst) result))
- (else (lp (cdr lst) (cons (car lst) result))))))
+ (define (kons a b) (if (and (pair? b) (= a (car b))) b (cons a b)))
+ (reverse (fold kons '() (sort lst <))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
commit ff8c5725cde0d6bbdeba6ea53ad6a08198a4db0a
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Sep 8 18:54:06 2019 +0800
[test-extras] rewrite strip-string to avoid repeat string-append
this is marginally more efficient, by keeping a list of (shared)
substrings, and only concatenating them when returning the stripped
string.
diff --git a/gnucash/report/report-system/test/test-extras.scm b/gnucash/report/report-system/test/test-extras.scm
index 0354e544f..210708381 100644
--- a/gnucash/report/report-system/test/test-extras.scm
+++ b/gnucash/report/report-system/test/test-extras.scm
@@ -61,14 +61,14 @@
render)))
(define (strip-string s1 s2)
- (let loop ((str s1))
+ (let loop ((str s1)
+ (res '()))
(let ((startpos (string-contains str (format #f "<~a" s2)))
(endpos (string-contains str (format #f "</~a>" s2))))
(if (and startpos endpos)
- (loop (string-append
- (string-take str startpos)
- (string-drop str (+ endpos (string-length s2) 3))))
- str))))
+ (loop (substring str (+ endpos (string-length s2) 3))
+ (cons (substring str 0 startpos) res))
+ (string-concatenate-reverse (cons str res))))))
(export gnc:options->sxml)
(define* (gnc:options->sxml uuid options prefix test-title #:key strip-tag)
commit b05c57a948cac6c665c6134ccf03335f3135900e
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Sep 7 19:36:34 2019 +0800
[html-acct-table] compact functions
diff --git a/gnucash/report/report-system/html-acct-table.scm b/gnucash/report/report-system/html-acct-table.scm
index 8d49f32c4..c0fff8db3 100644
--- a/gnucash/report/report-system/html-acct-table.scm
+++ b/gnucash/report/report-system/html-acct-table.scm
@@ -495,6 +495,7 @@
;; user. This class simply maps its contents to the html-table.
;;
+(use-modules (srfi srfi-2))
(use-modules (srfi srfi-9))
;; this is to work around a bug in the HTML export sytmem
@@ -554,39 +555,28 @@
;; helper for fetching values from the key/val environment alist
(define (get-val alist key)
(let ((lst (assoc-ref alist key)))
- (if lst (car lst) lst)))
-
-
+ (and lst (car lst))))
;; helper to plop <env> in the next available env cell
(define (add-row env)
(let* ((html-table (gnc:_html-acct-table-matrix_ acct-table))
(row (gnc:html-table-num-rows html-table)))
- (gnc:html-table-set-cell!
- html-table
- row
- 0
- env)
- row
- )
- )
+ (gnc:html-table-set-cell! html-table row 0 env)
+ row))
;; Add more stuff to an existing row
(define (append-to-row row env)
(gnc:html-acct-table-set-row-env! acct-table row
(append (gnc:html-acct-table-get-row-env acct-table row) env)))
-
+
(let* ((env (gnc:_html-acct-table-env_ acct-table))
;; establish all input parameters and their defaults
(depth-limit (let ((lim (get-val env 'display-tree-depth)))
- (if (or (equal? lim 'unlimited)
- (equal? lim 'all))
- #f ;; BUG? other code expects integer here
- lim)))
+ (and (number? lim) lim)))
(limit-behavior (or (get-val env 'depth-limit-behavior) 'summarize))
(indent (or (get-val env 'initial-indent) 0))
(less-p (let ((pred (get-val env 'account-less-p)))
- (if (equal? pred #t) gnc:account-code-less-p pred)))
+ (if (eq? pred #t) gnc:account-code-less-p pred)))
(start-date (get-val env 'start-date))
(end-date (or (get-val env 'end-date)
(gnc:get-today)))
@@ -594,18 +584,15 @@
(gnc-default-report-currency)))
;; BUG: other code expects a real function here, maybe
;; someone was thinking price-source?
- (exchange-fn (or (get-val env 'exchange-fn)
- #f))
- (get-balance-fn (or (get-val env 'get-balance-fn) #f))
+ (exchange-fn (get-val env 'exchange-fn))
+ (get-balance-fn (get-val env 'get-balance-fn))
(column-header (let ((cell (get-val env 'column-header)))
- (if (equal? cell #t)
+ (if (eq? cell #t)
(gnc:make-html-table-cell "Account name")
cell)))
(subtotal-mode (get-val env 'parent-account-subtotal-mode))
(zero-mode (let ((mode (get-val env 'zero-balance-mode)))
- (or (if (equal? mode #t) 'show-leaf-acct mode)
- 'show-leaf-acct)
- ))
+ (if (boolean? mode) 'show-leaf-acct mode)))
(label-mode (or (get-val env 'account-label-mode) 'anchor))
(balance-mode (or (get-val env 'balance-mode) 'post-closing))
(closing-pattern (or (get-val env 'closing-pattern)
@@ -613,16 +600,12 @@
(list 'str (_ "Closing Entries"))
(list 'cased #f)
(list 'regexp #f)
- (list 'closing #t)
- )
- ))
+ (list 'closing #t))))
(adjusting-pattern (or (get-val env 'adjusting-pattern)
(list
(list 'str (_ "Adjusting Entries"))
(list 'cased #f)
- (list 'regexp #f)
- )
- ))
+ (list 'regexp #f))))
(report-budget (or (get-val env 'report-budget) #f))
;; local variables
(toplvl-accts
@@ -637,19 +620,15 @@
;; helper to calculate the balances for all required accounts
(define (calculate-balances accts start-date end-date get-balance-fn)
- (define (calculate-balances-helper accts start-date end-date acct-balances)
- (if (not (null? accts))
- (begin
- ;; using the existing function that cares about balance-mode
- ;; maybe this should get replaces at some point.
- (hash-set! acct-balances (gncAccountGetGUID (car accts))
- (get-balance-fn (car accts) start-date end-date))
- (calculate-balances-helper (cdr accts) start-date end-date acct-balances)
- )
- acct-balances)
- )
+ (define ret-hash (make-hash-table))
+ (define (calculate-balances-helper)
+ (for-each
+ (lambda (acct)
+ (hash-set! ret-hash (gncAccountGetGUID acct)
+ (get-balance-fn acct start-date end-date)))
+ accts))
- (define (calculate-balances-simple accts start-date end-date hash-table)
+ (define (calculate-balances-simple)
(define (merge-splits splits subtract?)
(for-each
(lambda (split)
@@ -657,101 +636,72 @@
(guid (gncAccountGetGUID acct))
(acct-comm (xaccAccountGetCommodity acct))
(shares (xaccSplitGetAmount split))
- (hash (hash-ref hash-table guid)))
- (if (not hash)
- (begin (set! hash (gnc:make-commodity-collector))
- (hash-set! hash-table guid hash)))
- (hash 'add acct-comm (if subtract?
- (gnc-numeric-neg shares)
- shares))))
+ (hash (hash-ref ret-hash guid)))
+ (unless hash
+ (set! hash (gnc:make-commodity-collector))
+ (hash-set! ret-hash guid hash))
+ (hash 'add acct-comm (if subtract? (- shares) shares))))
splits))
- ;; If you pass a null account list to gnc:account-get-trans-type-splits-interval
- ;; it returns splits from all accounts rather than from no accounts. This is
- ;; probably a bug but we'll work around it for now.
- (if (not (null? accts))
- (begin
- (merge-splits (gnc:account-get-trans-type-splits-interval
- accts #f start-date end-date)
- #f)
- (cond
- ((equal? balance-mode 'post-closing) #t)
-
- ((equal? balance-mode 'pre-closing)
- (merge-splits (gnc:account-get-trans-type-splits-interval
- accts closing-pattern start-date end-date)
- #t))
-
- ((equal? balance-mode 'pre-adjusting)
- (merge-splits (gnc:account-get-trans-type-splits-interval
- accts closing-pattern start-date end-date)
- #t)
- (merge-splits (gnc:account-get-trans-type-splits-interval
- accts adjusting-pattern start-date end-date)
- #t))
- (else (begin (display "you fail it")
- (newline))))))
- hash-table
- )
+ (merge-splits (gnc:account-get-trans-type-splits-interval
+ accts #f start-date end-date)
+ #f)
+
+ (case balance-mode
+ ((post-closing) #f)
+
+ ;; remove closing entries
+ ((pre-closing)
+ (merge-splits (gnc:account-get-trans-type-splits-interval
+ accts closing-pattern start-date end-date) #t))
+
+ ;; remove closing and adjusting entries
+ ((pre-adjusting)
+ (merge-splits (gnc:account-get-trans-type-splits-interval
+ accts closing-pattern start-date end-date) #t)
+ (merge-splits (gnc:account-get-trans-type-splits-interval
+ accts adjusting-pattern start-date end-date) #t))
+
+ (else
+ (display "you fail it\n"))))
(if get-balance-fn
- (calculate-balances-helper accts start-date end-date
- (make-hash-table 23))
- (calculate-balances-simple accts start-date end-date
- (make-hash-table 23))
- )
- )
+ (calculate-balances-helper)
+ (calculate-balances-simple))
+ ret-hash)
(define (traverse-accounts! accts acct-depth logi-depth new-balances)
-
+
(define (use-acct? acct)
;; BUG? when depth-limit is not integer but boolean?
- (and (or (equal? limit-behavior 'flatten) (< logi-depth depth-limit))
- (member acct accounts)
- )
- )
+ (and (or (eq? limit-behavior 'flatten)
+ (< logi-depth depth-limit))
+ (member acct accounts)))
;; helper function to return a cached balance from a list of
;; ( acct . balance ) cells
(define (get-balance acct-balances acct)
- (let ((this-collector (gnc:make-commodity-collector)))
- (this-collector
- 'merge
- (or (hash-ref acct-balances (gncAccountGetGUID acct))
- ;; return a zero commodity collector
- (gnc:make-commodity-collector))
- #f)
- this-collector
- )
- )
+ (let ((this-collector (gnc:make-commodity-collector))
+ (acct-coll (hash-ref acct-balances (gncAccountGetGUID acct)
+ (gnc:make-commodity-collector))))
+ (this-collector 'merge acct-coll #f)
+ this-collector))
-
- ;; helper function that returns a cached balance from a list of
- ;; ( acct . balance ) cells for the given account *and* its
+ ;; helper function that returns a cached balance from a list of
+ ;; ( acct . balance) cells for the given account *and* its
;; sub-accounts.
(define (get-balance-sub acct-balances account)
- ;; its important to make a *new* collector for this, otherwise we're dealing with
- ;; pointers to the current collectors in our acct-balances hash and that's a
- ;; problem -- the balances get changed.
- (let ((this-collector (gnc:make-commodity-collector)))
- ;; get the balance of the parent account and stick it on the collector
- ;; that nice shiny *NEW* collector!!
- (this-collector 'merge (get-balance acct-balances account) #f)
- (for-each
- (lambda (x) (if x (this-collector 'merge x #f)))
- (gnc:account-map-descendants
- (lambda (a)
- (get-balance acct-balances a ))
- account))
+ (let ((this-collector (gnc:make-commodity-collector)))
+ (for-each
+ (lambda (acct)
+ (this-collector 'merge (get-balance acct-balances acct) #f))
+ (gnc:accounts-and-all-descendants (list account)))
this-collector))
-
-
- (let ((disp-depth
- (if (integer? depth-limit)
- (min (- depth-limit 1) logi-depth)
- logi-depth))
- (row-added? #f)
- )
+
+ (let ((disp-depth (if (integer? depth-limit)
+ (min (- depth-limit 1) logi-depth)
+ logi-depth))
+ (row-added? #f))
(for-each
(lambda (acct)
@@ -816,11 +766,9 @@
(list 'exchange-fn exchange-fn)
)))
(row-env #f)
- (label (or (and (equal? label-mode 'anchor)
- account-anchor)
- (and (equal? label-mode 'name)
- (gnc:make-html-text account-name))
- ))
+ (label (case label-mode
+ ((anchor) account-anchor)
+ ((name) (gnc:make-html-text account-name))))
(row #f)
(children-displayed? #f)
)
@@ -1201,38 +1149,32 @@
((not (null? children)) parent-acct-bal-mode)
(else 'immediate-bal)))
- (comm-amt
- (get-val env (assq-ref '((immediate-bal . account-bal)
- (recursive-bal . recursive-bal)
- (omit-bal . #f))
- bal-method)))
- (amt (and comm-amt
- (if (gnc-reverse-balance acct)
- (gnc:commodity-collector-get-negated comm-amt)
- comm-amt)))
-
(zero-mode (let ((mode (get-val env 'zero-balance-display-mode)))
(if (boolean? mode)
'show-balance
mode)))
- (native-comm?
- (lambda (amt)
- (gnc:uniform-commodity? amt report-commodity)))
+ (amt (and-let* ((bal-syms '((immediate-bal . account-bal)
+ (recursive-bal . recursive-bal)
+ (omit-bal . #f)))
+ (bal-sym (assq-ref bal-syms bal-method))
+ (comm-amt (get-val env bal-sym)))
+ (cond
+ ((and (eq? zero-mode 'omit-balance)
+ (gnc-commodity-collector-allzero? comm-amt)) #f)
+ ((gnc-reverse-balance acct)
+ (gnc:commodity-collector-get-negated comm-amt))
+ (else comm-amt))))
- ;; amount is either a <gnc:monetary> or #f
- (amount (and amt
- (not (and (eq? zero-mode 'omit-balance)
- (gnc-commodity-collector-allzero? amt)))
- (cond
- ((and (not (native-comm? amt))
- (eq? multicommodity-mode 'table)
- (eq? row-type 'account-row))
- (gnc-commodity-table
- amt report-commodity exchange-fn))
- (else
- (gnc:sum-collector-commodity
- amt report-commodity exchange-fn)))))
+ (amount
+ (cond
+ ((not amt) #f)
+ ((and (not (gnc:uniform-commodity? amt report-commodity))
+ (eq? multicommodity-mode 'table)
+ (eq? row-type 'account-row))
+ (gnc-commodity-table amt report-commodity exchange-fn))
+ (else
+ (gnc:sum-collector-commodity amt report-commodity exchange-fn))))
(indented-depth (get-val env 'indented-depth))
(account-colspan (get-val env 'account-colspan))
Summary of changes:
gnucash/report/report-system/html-acct-table.scm | 246 +++++++++-------------
gnucash/report/report-system/test/test-extras.scm | 10 +-
gnucash/report/standard-reports/balsheet-pnl.scm | 51 ++---
libgnucash/scm/utilities.scm | 8 +-
4 files changed, 127 insertions(+), 188 deletions(-)
More information about the gnucash-changes
mailing list