gnucash maint: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Mon Mar 4 09:02:23 EST 2019
Updated via https://github.com/Gnucash/gnucash/commit/c419c6d9 (commit)
via https://github.com/Gnucash/gnucash/commit/e5495caa (commit)
via https://github.com/Gnucash/gnucash/commit/27511933 (commit)
via https://github.com/Gnucash/gnucash/commit/3ba0970d (commit)
via https://github.com/Gnucash/gnucash/commit/953b01cb (commit)
via https://github.com/Gnucash/gnucash/commit/58cc7f00 (commit)
via https://github.com/Gnucash/gnucash/commit/97bf596d (commit)
via https://github.com/Gnucash/gnucash/commit/5108accf (commit)
via https://github.com/Gnucash/gnucash/commit/66657f46 (commit)
via https://github.com/Gnucash/gnucash/commit/86cbebd0 (commit)
via https://github.com/Gnucash/gnucash/commit/9d38d7fa (commit)
via https://github.com/Gnucash/gnucash/commit/cd496cbe (commit)
via https://github.com/Gnucash/gnucash/commit/c8625ab5 (commit)
from https://github.com/Gnucash/gnucash/commit/d16d71df (commit)
commit c419c6d9e72baeb14ce6aea623d0879a59215930
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Mar 4 22:01:51 2019 +0800
[budget] clean up useless comments
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index af4a34ecd..72b46f932 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -42,8 +42,6 @@
;; define all option's names so that they are properly defined
;; in *one* place.
-;;(define optname-from-date (N_ "Start Date"))
-;;(define optname-to-date (N_ "End Date"))
(define optname-display-depth
(N_ "Account Display Depth"))
@@ -623,8 +621,6 @@
(define (budget-renderer report-obj)
(define (get-option pagename optname)
(get-option-val (gnc:report-options report-obj) pagename optname))
- ;; (gnc:lookup-option
- ;; (gnc:report-options report-obj) pagename optname)))
(gnc:report-starting reportname)
commit e5495caab918911c38d9ff03d6bc59273b68908a
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Mar 2 23:00:49 2019 +0800
[budget] compact gnc:html-table-display-budget-columns!
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index f27809bf1..af4a34ecd 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -355,98 +355,83 @@
(define (gnc:html-table-add-budget-line!
html-table rownum colnum budget acct rollup-budget?
column-list exchange-fn)
- (let* ((current-col (1+ colnum))
- (comm (xaccAccountGetCommodity acct))
+ (let* ((comm (xaccAccountGetCommodity acct))
(reverse-balance? (gnc-reverse-balance acct))
(income-acct? (eqv? (xaccAccountGetType acct) ACCT-TYPE-INCOME)))
;; Displays a set of budget column values
;;
;; Parameters
- ;; html-table - html table being created
- ;; rownum - row number
- ;; total? - is this a set of total columns
- ;; bgt-numeric-val - budget value, or #f if column not to be shown
- ;; act-numeric-val - actual value, or #f if column not to be shown
- ;; dif-numeric val - difference value, or #f if column not to be shown
- (define (gnc:html-table-display-budget-columns!
- html-table rownum total? bgt-numeric-val act-numeric-val
- dif-numeric-val)
- (let* ((bgt-val #f)
- (act-val #f)
- (dif-val #f)
- (style-tag (if total? "total-number-cell" "number-cell"))
- (style-tag-neg (string-append style-tag "-neg")))
+ ;; style-tag - cell style
+ ;; col - starting column to modify in html-table
+ ;; bgt-val - budget value
+ ;; act-val - actual value
+ ;; dif-val - difference value
+ ;;
+ ;; Returns
+ ;; col - next column
+ (define (disp-cols style-tag col0
+ bgt-val act-val dif-val)
+ (let* ((style-tag-neg (string-append style-tag "-neg"))
+ (col1 (+ col0 (if show-budget? 1 0)))
+ (col2 (+ col1 (if show-actual? 1 0)))
+ (col3 (+ col2 (if show-diff? 1 0))))
(if show-budget?
- (begin
- (set! bgt-val (if (zero? bgt-numeric-val) "."
- (gnc:make-gnc-monetary comm bgt-numeric-val)))
- (gnc:html-table-set-cell/tag!
- html-table rownum current-col style-tag bgt-val)
- (set! current-col (+ current-col 1))))
+ (gnc:html-table-set-cell/tag!
+ html-table rownum col0 style-tag
+ (if (zero? bgt-val) "."
+ (gnc:make-gnc-monetary comm bgt-val))))
(if show-actual?
- (begin
- (set! act-val (gnc:make-gnc-monetary comm act-numeric-val))
- (gnc:html-table-set-cell/tag!
- html-table rownum current-col
- (if (negative? act-numeric-val)
- style-tag-neg
- style-tag)
- act-val)
- (set! current-col (+ current-col 1))))
+ (gnc:html-table-set-cell/tag!
+ html-table rownum col1
+ (if (negative? act-val) style-tag-neg style-tag)
+ (gnc:make-gnc-monetary comm act-val)))
(if show-diff?
- (begin
- (set! dif-val
- (if (and (zero? bgt-numeric-val)
- (zero? act-numeric-val))
- "."
- (gnc:make-gnc-monetary comm dif-numeric-val)))
- (gnc:html-table-set-cell/tag!
- html-table rownum current-col
- (if (negative? dif-numeric-val)
- style-tag-neg
- style-tag)
- dif-val)
- (set! current-col (+ current-col 1))))))
+ (gnc:html-table-set-cell/tag!
+ html-table rownum col2
+ (if (negative? dif-val) style-tag-neg style-tag)
+ (if (and (zero? bgt-val) (zero? act-val)) "."
+ (gnc:make-gnc-monetary comm dif-val))))
+ col3))
(let loop ((column-list column-list)
(bgt-total 0)
- (act-total 0))
+ (act-total 0)
+ (current-col (1+ colnum)))
(cond
((null? column-list)
#f)
((eq? (car column-list) 'total)
- (gnc:html-table-display-budget-columns!
- html-table rownum #t bgt-total act-total
- (if income-acct?
- (- act-total bgt-total)
- (- bgt-total act-total)))
- (loop (cdr column-list)))
+ (loop (cdr column-list)
+ bgt-total
+ act-total
+ (disp-cols "total-number-cell" current-col
+ bgt-total act-total
+ (if income-acct?
+ (- act-total bgt-total)
+ (- bgt-total act-total)))))
(else
(let* ((period-list (if (list? (car column-list))
(car column-list)
(list (car column-list))))
- (bgt-numeric-val (gnc:get-account-periodlist-budget-value
- budget acct period-list))
- (act-numeric-abs (gnc:get-account-periodlist-actual-value
- budget acct period-list))
- (act-numeric-val (if reverse-balance?
- (- act-numeric-abs)
- act-numeric-abs))
- (dif-numeric-val (if income-acct?
- (- act-numeric-val bgt-numeric-val)
- (- bgt-numeric-val act-numeric-val))))
-
- (gnc:html-table-display-budget-columns!
- html-table rownum #f
- bgt-numeric-val act-numeric-val dif-numeric-val))
-
- (loop (cdr column-list)
- (+ bgt-total bgt-numeric-val)
- (+ act-total act-numeric-val)))))))
+ (bgt-val (gnc:get-account-periodlist-budget-value
+ budget acct period-list))
+ (act-abs (gnc:get-account-periodlist-actual-value
+ budget acct period-list))
+ (act-val (if reverse-balance?
+ (- act-abs)
+ act-abs))
+ (dif-val (if income-acct?
+ (- act-val bgt-val)
+ (- bgt-val act-val))))
+ (loop (cdr column-list)
+ (+ bgt-total bgt-val)
+ (+ act-total act-val)
+ (disp-cols "number-cell" current-col
+ bgt-val act-val dif-val))))))))
;; Adds header rows to the budget report. The columns are
;; specified by the column-list parameter.
commit 275119335bc6c24e31ebc7741ebd073cc4a3c3b8
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Mar 3 13:36:50 2019 +0800
[budget] inline gnc:html-table-add-budget-line-columns!
This function is used only once. Inline it.
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index a36a15497..f27809bf1 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -356,8 +356,6 @@
html-table rownum colnum budget acct rollup-budget?
column-list exchange-fn)
(let* ((current-col (1+ colnum))
- (bgt-total 0)
- (act-total 0)
(comm (xaccAccountGetCommodity acct))
(reverse-balance? (gnc-reverse-balance acct))
(income-acct? (eqv? (xaccAccountGetType acct) ACCT-TYPE-INCOME)))
@@ -411,45 +409,9 @@
dif-val)
(set! current-col (+ current-col 1))))))
- ;; Adds a set of column values to the budget report for a specific list
- ;; of periods.
- ;;
- ;; Parameters:
- ;; html-table - html table being created
- ;; rownum - row number
- ;; budget - budget to use
- ;; acct - account being displayed
- ;; period-list - list of periods to use
- (define (gnc:html-table-add-budget-line-columns!
- html-table rownum budget acct period-list)
- (let* (;; budgeted amount
- (bgt-numeric-val (gnc:get-account-periodlist-budget-value
- budget acct period-list))
- ;; actual amount
- (act-numeric-abs (gnc:get-account-periodlist-actual-value
- budget acct period-list))
- (act-numeric-val
- (if reverse-balance?
- (- act-numeric-abs)
- act-numeric-abs))
-
- ;; difference (budget to actual)
- (dif-numeric-val
- (- bgt-numeric-val act-numeric-val)))
-
- (if (not (zero? bgt-numeric-val))
- (begin
- (set! bgt-total (+ bgt-total bgt-numeric-val))
- (set! bgt-total-unset? #f)))
- (set! act-total (+ act-total act-numeric-val))
- (if income-acct?
- (set! dif-numeric-val
- (- act-numeric-val bgt-numeric-val)))
- (gnc:html-table-display-budget-columns!
- html-table rownum #f
- bgt-numeric-val act-numeric-val dif-numeric-val)))
-
- (let loop ((column-list column-list))
+ (let loop ((column-list column-list)
+ (bgt-total 0)
+ (act-total 0))
(cond
((null? column-list)
@@ -464,12 +426,27 @@
(loop (cdr column-list)))
(else
- (gnc:html-table-add-budget-line-columns!
- html-table rownum budget acct
- (if (list? (car column-list))
- (car column-list)
- (list (car column-list))))
- (loop (cdr column-list)))))))
+ (let* ((period-list (if (list? (car column-list))
+ (car column-list)
+ (list (car column-list))))
+ (bgt-numeric-val (gnc:get-account-periodlist-budget-value
+ budget acct period-list))
+ (act-numeric-abs (gnc:get-account-periodlist-actual-value
+ budget acct period-list))
+ (act-numeric-val (if reverse-balance?
+ (- act-numeric-abs)
+ act-numeric-abs))
+ (dif-numeric-val (if income-acct?
+ (- act-numeric-val bgt-numeric-val)
+ (- bgt-numeric-val act-numeric-val))))
+
+ (gnc:html-table-display-budget-columns!
+ html-table rownum #f
+ bgt-numeric-val act-numeric-val dif-numeric-val))
+
+ (loop (cdr column-list)
+ (+ bgt-total bgt-numeric-val)
+ (+ act-total act-numeric-val)))))))
;; Adds header rows to the budget report. The columns are
;; specified by the column-list parameter.
commit 3ba0970d9d87268afb1f5743cc630df0c0717ec4
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Mar 3 13:37:08 2019 +0800
[budget] compact gnc:html-table-add-budget-line!
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index c087bfaf2..a36a15497 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -355,13 +355,12 @@
(define (gnc:html-table-add-budget-line!
html-table rownum colnum budget acct rollup-budget?
column-list exchange-fn)
- (let* ((current-col (+ colnum 1))
+ (let* ((current-col (1+ colnum))
(bgt-total 0)
- (bgt-total-unset? #t)
(act-total 0)
(comm (xaccAccountGetCommodity acct))
(reverse-balance? (gnc-reverse-balance acct))
- (income-acct? (eq? (xaccAccountGetType acct) ACCT-TYPE-INCOME)))
+ (income-acct? (eqv? (xaccAccountGetType acct) ACCT-TYPE-INCOME)))
;; Displays a set of budget column values
;;
@@ -450,22 +449,27 @@
html-table rownum #f
bgt-numeric-val act-numeric-val dif-numeric-val)))
- (while (not (null? column-list))
- (let* ((col-info (car column-list)))
- (cond
- ((equal? col-info 'total)
- (gnc:html-table-display-budget-columns!
- html-table rownum #t bgt-total act-total
- (if income-acct?
- (- act-total bgt-total)
- (- bgt-total act-total))))
- ((list? col-info)
- (gnc:html-table-add-budget-line-columns!
- html-table rownum budget acct col-info))
- (else
- (gnc:html-table-add-budget-line-columns!
- html-table rownum budget acct (list col-info))))
- (set! column-list (cdr column-list))))))
+ (let loop ((column-list column-list))
+ (cond
+
+ ((null? column-list)
+ #f)
+
+ ((eq? (car column-list) 'total)
+ (gnc:html-table-display-budget-columns!
+ html-table rownum #t bgt-total act-total
+ (if income-acct?
+ (- act-total bgt-total)
+ (- bgt-total act-total)))
+ (loop (cdr column-list)))
+
+ (else
+ (gnc:html-table-add-budget-line-columns!
+ html-table rownum budget acct
+ (if (list? (car column-list))
+ (car column-list)
+ (list (car column-list))))
+ (loop (cdr column-list)))))))
;; Adds header rows to the budget report. The columns are
;; specified by the column-list parameter.
commit 953b01cbc87e63e6e375935d9e63b75ea59e593f
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Mar 3 00:05:54 2019 +0800
[budget] compact gnc:html-table-add-budget-values!
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index 448336e15..c087bfaf2 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -295,10 +295,9 @@
(show-diff? (get-val params 'show-difference))
(show-totalcol? (get-val params 'show-totalcol))
(rollup-budget? (get-val params 'rollup-budget))
+ (use-ranges? (get-val params 'use-ranges))
(num-rows (gnc:html-acct-table-num-rows acct-table))
- (rownum 0)
(numcolumns (gnc:html-table-num-columns html-table))
- ;;(html-table (or html-table (gnc:make-html-table)))
;; WARNING: we implicitly depend here on the details of
;; gnc:html-table-add-account-balances. Specifically, we
;; assume that it makes twice as many columns as it uses for
@@ -306,11 +305,6 @@
;; assumption.
(colnum (quotient numcolumns 2)))
- (define (number-cell-tag x)
- (if (negative? x) "number-cell-neg" "number-cell"))
- (define (total-number-cell-tag x)
- (if (negative? x) "total-number-cell-neg" "total-number-cell"))
-
;; Calculate the value to use for the budget of an account for a
;; specific set of periods. If there is 1 period, use that
;; period's budget value. Otherwise, sum the budgets for all of
@@ -611,28 +605,26 @@
(if show-total? '(total) '()))))))
;; end of defines
- (let* ((rownum 0)
- (use-ranges? (get-val params 'use-ranges))
- (column-info-list (calc-periods
- budget
- (calc-user-period
- budget use-ranges?
- (get-val params 'user-start-period)
- (get-val params 'user-start-period-exact))
- (calc-user-period
- budget use-ranges?
- (get-val params 'user-end-period)
- (get-val params 'user-end-period-exact))
- (get-val params 'collapse-before)
- (get-val params 'collapse-after)
- show-totalcol?))
- ;;(html-table (or html-table (gnc:make-html-table)))
- ;; WARNING: we implicitly depend here on the details of
- ;; gnc:html-table-add-account-balances. Specifically, we
- ;; assume that it makes twice as many columns as it uses for
- ;; account labels. For now, that seems to be a valid
- ;; assumption.
- )
+ (let ((column-info-list (calc-periods
+ budget
+ (calc-user-period
+ budget use-ranges?
+ (get-val params 'user-start-period)
+ (get-val params 'user-start-period-exact))
+ (calc-user-period
+ budget use-ranges?
+ (get-val params 'user-end-period)
+ (get-val params 'user-end-period-exact))
+ (get-val params 'collapse-before)
+ (get-val params 'collapse-after)
+ show-totalcol?))
+ ;;(html-table (or html-table (gnc:make-html-table)))
+ ;; WARNING: we implicitly depend here on the details of
+ ;; gnc:html-table-add-account-balances. Specifically, we
+ ;; assume that it makes twice as many columns as it uses for
+ ;; account labels. For now, that seems to be a valid
+ ;; assumption.
+ )
;;debug output for control of period list calculation
(gnc:debug "use-ranges? =" use-ranges?)
(gnc:debug "user-start-period =" (get-val params 'user-start-period))
@@ -642,15 +634,16 @@
(gnc:debug "column-info-list=" column-info-list)
;; call gnc:html-table-add-budget-line! for each account
- (while (< rownum num-rows)
- (let* ((env (append (gnc:html-acct-table-get-row-env acct-table rownum)
- params))
- (acct (get-val env 'account))
- (exchange-fn (get-val env 'exchange-fn)))
- (gnc:html-table-add-budget-line!
- html-table rownum colnum budget acct rollup-budget?
- column-info-list exchange-fn)
- (set! rownum (+ rownum 1))))
+ (let loop ((rownum 0))
+ (when (< rownum num-rows)
+ (let* ((env (append (gnc:html-acct-table-get-row-env acct-table rownum)
+ params))
+ (acct (get-val env 'account))
+ (exchange-fn (get-val env 'exchange-fn)))
+ (gnc:html-table-add-budget-line!
+ html-table rownum colnum budget acct rollup-budget?
+ column-info-list exchange-fn)
+ (loop (1+ rownum)))))
;; column headers
(gnc:html-table-add-budget-headers!
commit 58cc7f00a5b2da9748555bdd4cfbb2b86f9776e5
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Mar 2 23:07:15 2019 +0800
[budget] compact budget-renderer
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index b521d91d0..448336e15 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -684,116 +684,100 @@
(show-zb-accts? (get-option gnc:pagename-display
optname-show-zb-accounts))
(use-ranges? (get-option gnc:pagename-general optname-use-budget-period-range))
- (include-collapse-before? (if use-ranges?
+ (include-collapse-before? (and use-ranges?
+ (get-option gnc:pagename-general
+ optname-period-collapse-before)))
+ (include-collapse-after? (and use-ranges?
(get-option gnc:pagename-general
- optname-period-collapse-before)
- #f))
- (include-collapse-after? (if use-ranges?
- (get-option gnc:pagename-general
- optname-period-collapse-after)
- #f))
- (row-num 0)
- (work-done 0)
- (work-to-do 0)
+ optname-period-collapse-after)))
(show-full-names? (get-option gnc:pagename-general
optname-show-full-names))
- (doc (gnc:make-html-document)))
-
+ (doc (gnc:make-html-document))
+ (accounts (append accounts
+ (filter (lambda (acc) (not (member acc accounts)))
+ (if show-subaccts?
+ (gnc:acccounts-get-all-subaccounts accounts)
+ '())))))
;; end of defines
- ;; add subaccounts if requested
- (if show-subaccts?
- (let ((sub-accounts (gnc:acccounts-get-all-subaccounts accounts)))
- (for-each
- (lambda (sub-account)
- (if (not (member sub-account accounts))
- (set! accounts (cons sub-account accounts))))
- sub-accounts)))
-
(cond
+
((null? accounts)
;; No accounts selected.
(gnc:html-document-add-object!
- doc
- (gnc:html-make-no-account-warning reportname (gnc:report-id report-obj))))
+ doc (gnc:html-make-no-account-warning reportname (gnc:report-id report-obj))))
+
((not budget-valid?)
;; No budget selected.
(gnc:html-document-add-object!
doc (gnc:html-make-generic-budget-warning reportname)))
- (else (begin
- (let* ((tree-depth (if (equal? display-depth 'all)
- (accounts-get-children-depth accounts)
- display-depth))
- (to-period-val (lambda (v)
- (inexact->exact
- (truncate
- (get-option gnc:pagename-general v)))))
- (env (list
- (list 'start-date (gnc:budget-get-start-date budget))
- (list 'end-date (gnc:budget-get-end-date budget))
- (list 'display-tree-depth tree-depth)
- (list 'depth-limit-behavior
- (if bottom-behavior 'flatten 'summarize))
- (list 'zero-balance-mode
- (if show-zb-accts? 'show-leaf-acct 'omit-leaf-acct))
- (list 'report-budget budget)))
- (acct-table #f)
- (html-table (gnc:make-html-table))
- (params '())
- (paramsBudget
- (list
- (list 'show-actual
- (get-option gnc:pagename-display optname-show-actual))
- (list 'show-budget
- (get-option gnc:pagename-display optname-show-budget))
- (list 'show-difference
- (get-option gnc:pagename-display optname-show-difference))
- (list 'show-totalcol
- (get-option gnc:pagename-display optname-show-totalcol))
- (list 'rollup-budget
- (get-option gnc:pagename-display optname-rollup-budget))
- (list 'use-ranges use-ranges?)
- (list 'collapse-before include-collapse-before?)
- (list 'collapse-after include-collapse-after?)
- (list 'user-start-period
- (get-option gnc:pagename-general
- optname-budget-period-start))
- (list 'user-end-period
- (get-option gnc:pagename-general
- optname-budget-period-end))
- (list 'user-start-period-exact
- (to-period-val optname-budget-period-start-exact))
- (list 'user-end-period-exact
- (to-period-val optname-budget-period-end-exact))))
- (report-name (get-option gnc:pagename-general
- gnc:optname-reportname)))
-
- (gnc:html-document-set-title!
- doc (format #f (_ "~a: ~a")
- report-name (gnc-budget-get-name budget)))
-
- (set! accounts (sort accounts account-full-name<?))
-
- (set! acct-table
- (gnc:make-html-acct-table/env/accts env accounts))
-
- ;; We do this in two steps: First the account names... the
- ;; add-account-balances will actually compute and add a
- ;; bunch of current account balances, too, but we'll
- ;; overwrite them.
- (set! html-table (gnc:html-table-add-account-balances
- #f acct-table params))
-
- ;; ... then the budget values
- (gnc:html-table-add-budget-values!
- html-table acct-table budget paramsBudget)
-
- ;; hmmm... I expected that add-budget-values would have to
- ;; clear out any unused columns to the right, out to the
- ;; table width, since the add-account-balance had put stuff
- ;; there, but it doesn't seem to matter.
-
- (gnc:html-document-add-object! doc html-table)))))
+
+ (else
+ (let* ((tree-depth (if (eq? display-depth 'all)
+ (accounts-get-children-depth accounts)
+ display-depth))
+ (to-period-val (lambda (v)
+ (inexact->exact
+ (truncate
+ (get-option gnc:pagename-general v)))))
+ (env (list
+ (list 'start-date (gnc:budget-get-start-date budget))
+ (list 'end-date (gnc:budget-get-end-date budget))
+ (list 'display-tree-depth tree-depth)
+ (list 'depth-limit-behavior
+ (if bottom-behavior 'flatten 'summarize))
+ (list 'zero-balance-mode
+ (if show-zb-accts? 'show-leaf-acct 'omit-leaf-acct))
+ (list 'report-budget budget)))
+ (accounts (sort accounts account-full-name<?))
+ (acct-table (gnc:make-html-acct-table/env/accts env accounts))
+ (paramsBudget
+ (list
+ (list 'show-actual
+ (get-option gnc:pagename-display optname-show-actual))
+ (list 'show-budget
+ (get-option gnc:pagename-display optname-show-budget))
+ (list 'show-difference
+ (get-option gnc:pagename-display optname-show-difference))
+ (list 'show-totalcol
+ (get-option gnc:pagename-display optname-show-totalcol))
+ (list 'rollup-budget
+ (get-option gnc:pagename-display optname-rollup-budget))
+ (list 'use-ranges use-ranges?)
+ (list 'collapse-before include-collapse-before?)
+ (list 'collapse-after include-collapse-after?)
+ (list 'user-start-period
+ (get-option gnc:pagename-general
+ optname-budget-period-start))
+ (list 'user-end-period
+ (get-option gnc:pagename-general
+ optname-budget-period-end))
+ (list 'user-start-period-exact
+ (to-period-val optname-budget-period-start-exact))
+ (list 'user-end-period-exact
+ (to-period-val optname-budget-period-end-exact))))
+ (report-name (get-option gnc:pagename-general
+ gnc:optname-reportname)))
+
+ (gnc:html-document-set-title!
+ doc (format #f (_ "~a: ~a")
+ report-name (gnc-budget-get-name budget)))
+
+ ;; We do this in two steps: First the account names... the
+ ;; add-account-balances will actually compute and add a
+ ;; bunch of current account balances, too, but we'll
+ ;; overwrite them.
+ (let ((html-table (gnc:html-table-add-account-balances #f acct-table '())))
+
+ ;; ... then the budget values
+ (gnc:html-table-add-budget-values! html-table acct-table budget paramsBudget)
+
+ ;; hmmm... I expected that add-budget-values would have to
+ ;; clear out any unused columns to the right, out to the
+ ;; table width, since the add-account-balance had put stuff
+ ;; there, but it doesn't seem to matter.
+
+ (gnc:html-document-add-object! doc html-table)))))
(gnc:report-finished)
doc))
commit 97bf596d3156736c21d14b9ab5704fc0b2025ec6
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Mar 2 23:07:02 2019 +0800
[budget] compact calc-periods
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index 398a5a42f..b521d91d0 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -595,24 +595,20 @@
(define (calc-periods
budget user-start user-end collapse-before? collapse-after? show-total?)
(define (range start end)
- (define (int-range current end step lst)
- (if (>= current end)
- lst
- (int-range (+ current step) end step (cons current lst))))
- (reverse (int-range (if (number? start) start 0) end 1 '())))
+ (iota (- end start) start))
(let* ((num-periods (gnc-budget-get-num-periods budget))
- (range-start (if user-start user-start 0))
- (range-end (if user-end (+ 1 user-end) num-periods))
+ (range-start (or user-start 0))
+ (range-end (if user-end (1+ user-end) num-periods))
(fold-before-start 0)
(fold-before-end (if collapse-before? range-start 0))
(fold-after-start (if collapse-after? range-end num-periods))
(fold-after-end num-periods))
- (map (lambda (x) (if (and (list? x) (= 1 (length x))) (car x) x))
+ (map (lambda (x) (if (and (list? x) (null? (cdr x))) (car x) x))
(filter (lambda (x) (not (null? x)))
(append (list (range fold-before-start fold-before-end))
(range range-start range-end)
(list (range fold-after-start fold-after-end))
- (if show-total? (list 'total) '()))))))
+ (if show-total? '(total) '()))))))
;; end of defines
(let* ((rownum 0)
commit 5108accfcd675013e409f9c0f525f09b24971949
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Mar 2 23:06:06 2019 +0800
[budget] compact gnc:html-table-add-budget-headers!
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index a7e3fe9d4..398a5a42f 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -483,68 +483,60 @@
;; column-list - column info list
(define (gnc:html-table-add-budget-headers!
html-table colnum budget column-list)
- (let* ((current-col (+ colnum 1))
- (col-list column-list)
- (col-span 0))
- (if show-budget? (set! col-span (+ col-span 1)))
- (if show-actual? (set! col-span (+ col-span 1)))
- (if show-diff? (set! col-span (+ col-span 1)))
- (if (eqv? col-span 0) (set! col-span 1))
+ (let* ((current-col (1+ colnum))
+ (col-span (max 1 (count identity
+ (list show-budget? show-actual? show-diff?))))
+ (period-to-date-string (lambda (p)
+ (qof-print-date
+ (gnc-budget-get-period-start-date budget p)))))
;; prepend 2 empty rows
(gnc:html-table-prepend-row! html-table '())
(gnc:html-table-prepend-row! html-table '())
- (while (not (= (length col-list) 0))
- (let* ((col-info (car col-list))
- (tc #f)
- (period-to-date-string (lambda (p)
- (qof-print-date
- (gnc-budget-get-period-start-date
- budget p)))))
- (cond
- ((equal? col-info 'total)
- (gnc:html-table-set-cell! html-table 0 current-col (_ "Total")))
- ((list? col-info)
- (gnc:html-table-set-cell!
- html-table 0 current-col (string-append
- (period-to-date-string (car col-info))
- " – "
- (period-to-date-string
- (car (reverse col-info))))))
- (else
- (gnc:html-table-set-cell!
- html-table 0 current-col (period-to-date-string col-info))))
- (set! tc (gnc:html-table-get-cell html-table 0 current-col))
- (gnc:html-table-cell-set-colspan! tc col-span)
- (gnc:html-table-cell-set-tag! tc "centered-label-cell")
- (set! current-col (+ current-col 1))
- (set! col-list (cdr col-list))))
+ (let loop ((column-list column-list)
+ (current-col current-col))
+ (unless (null? column-list)
+ (gnc:html-table-set-cell!
+ html-table 0 current-col
+ (cond
+ ((eq? (car column-list) 'total)
+ (_ "Total"))
+ ((list? (car column-list))
+ (string-append (period-to-date-string (car (car column-list)))
+ " – "
+ (period-to-date-string (last (car column-list)))))
+ (else
+ (period-to-date-string (car column-list)))))
+
+ (let ((tc (gnc:html-table-get-cell html-table 0 current-col)))
+ (gnc:html-table-cell-set-colspan! tc col-span)
+ (gnc:html-table-cell-set-tag! tc "centered-label-cell"))
+
+ (loop (cdr column-list)
+ (1+ current-col))))
;; make the column headers
- (set! col-list column-list)
- (set! current-col (+ colnum 1))
- (while (not (= (length column-list) 0))
- (let* ((col-info (car column-list)))
- (if show-budget?
- (begin
- (gnc:html-table-set-cell/tag!
- html-table 1 current-col "centered-label-cell"
- (_ "Bgt")) ;; Translators: Abbreviation for "Budget"
- (set! current-col (+ current-col 1))))
- (if show-actual?
- (begin
- (gnc:html-table-set-cell/tag!
- html-table 1 current-col "centered-label-cell"
- (_ "Act")) ;; Translators: Abbreviation for "Actual"
- (set! current-col (+ current-col 1))))
- (if show-diff?
- (begin
- (gnc:html-table-set-cell/tag!
- html-table 1 current-col "centered-label-cell"
- (_ "Diff")) ;; Translators: Abbreviation for "Difference"
- (set! current-col (+ current-col 1))))
- (set! column-list (cdr column-list))))))
+ (let loop ((column-list column-list)
+ (col0 current-col))
+ (unless (null? column-list)
+ (let* ((col1 (+ col0 (if show-budget? 1 0)))
+ (col2 (+ col1 (if show-actual? 1 0)))
+ (col3 (+ col2 (if show-diff? 1 0))))
+ (when show-budget?
+ (gnc:html-table-set-cell/tag!
+ html-table 1 col0 "centered-label-cell"
+ (_ "Bgt"))) ;; Translators: Abbreviation for "Budget"
+ (when show-actual?
+ (gnc:html-table-set-cell/tag!
+ html-table 1 col1 "centered-label-cell"
+ (_ "Act"))) ;; Translators: Abbreviation for "Actual"
+ (when show-diff?
+ (gnc:html-table-set-cell/tag!
+ html-table 1 col2 "centered-label-cell"
+ (_ "Diff"))) ;; Translators: Abbreviation for "Difference"
+ (loop (cdr column-list)
+ col3))))))
;; Determines the budget period relative to current period. Budget
;; period is current if it start time <= current time and end time
commit 66657f466e5d5b02e4e15b87f24001c385ccf8d7
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Mar 2 21:12:49 2019 +0800
[budget] convert iterative functions to use srfi-1
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index e473e4355..a7e3fe9d4 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -324,13 +324,11 @@
;; Return value:
;; Budget sum
(define (gnc:get-account-periodlist-budget-value budget acct periodlist)
- (cond
- ((= (length periodlist) 1)
- (gnc:get-account-period-rolledup-budget-value budget acct (car periodlist)))
- (else
- (+
- (gnc:get-account-period-rolledup-budget-value budget acct (car periodlist))
- (gnc:get-account-periodlist-budget-value budget acct (cdr periodlist))))))
+ (apply +
+ (map
+ (lambda (period)
+ (gnc:get-account-period-rolledup-budget-value budget acct period))
+ periodlist)))
;; Calculate the value to use for the actual of an account for a
;; specific set of periods. This is the sum of the actuals for
@@ -344,13 +342,10 @@
;; Return value:
;; Budget sum
(define (gnc:get-account-periodlist-actual-value budget acct periodlist)
- (cond
- ((= (length periodlist) 1)
- (gnc-budget-get-account-period-actual-value budget acct (car periodlist)))
- (else
- (+
- (gnc-budget-get-account-period-actual-value budget acct (car periodlist))
- (gnc:get-account-periodlist-actual-value budget acct (cdr periodlist))))))
+ (apply + (map
+ (lambda (period)
+ (gnc-budget-get-account-period-actual-value budget acct period))
+ periodlist)))
;; Adds a line to tbe budget report.
;;
commit 86cbebd0ac5c1d4f7170441eb5109d87182e3897
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Mar 2 21:03:43 2019 +0800
[budget] eradicate gnc-numeric methods
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index 75ffe741b..e473e4355 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -289,7 +289,7 @@
html-table acct-table budget params)
(let* ((get-val (lambda (alist key)
(let ((lst (assoc-ref alist key)))
- (if lst (car lst) lst))))
+ (and lst (car lst)))))
(show-actual? (get-val params 'show-actual))
(show-budget? (get-val params 'show-budget))
(show-diff? (get-val params 'show-difference))
@@ -306,12 +306,10 @@
;; assumption.
(colnum (quotient numcolumns 2)))
- (define (negative-numeric-p x)
- (if (gnc-numeric-p x) (gnc-numeric-negative-p x) #f))
(define (number-cell-tag x)
- (if (negative-numeric-p x) "number-cell-neg" "number-cell"))
+ (if (negative? x) "number-cell-neg" "number-cell"))
(define (total-number-cell-tag x)
- (if (negative-numeric-p x) "total-number-cell-neg" "total-number-cell"))
+ (if (negative? x) "total-number-cell-neg" "total-number-cell"))
;; Calculate the value to use for the budget of an account for a
;; specific set of periods. If there is 1 period, use that
@@ -330,10 +328,9 @@
((= (length periodlist) 1)
(gnc:get-account-period-rolledup-budget-value budget acct (car periodlist)))
(else
- (gnc-numeric-add
+ (+
(gnc:get-account-period-rolledup-budget-value budget acct (car periodlist))
- (gnc:get-account-periodlist-budget-value budget acct (cdr periodlist))
- GNC-DENOM-AUTO GNC-RND-ROUND))))
+ (gnc:get-account-periodlist-budget-value budget acct (cdr periodlist))))))
;; Calculate the value to use for the actual of an account for a
;; specific set of periods. This is the sum of the actuals for
@@ -351,10 +348,9 @@
((= (length periodlist) 1)
(gnc-budget-get-account-period-actual-value budget acct (car periodlist)))
(else
- (gnc-numeric-add
+ (+
(gnc-budget-get-account-period-actual-value budget acct (car periodlist))
- (gnc:get-account-periodlist-actual-value budget acct (cdr periodlist))
- GNC-DENOM-AUTO GNC-RND-ROUND))))
+ (gnc:get-account-periodlist-actual-value budget acct (cdr periodlist))))))
;; Adds a line to tbe budget report.
;;
@@ -371,9 +367,9 @@
html-table rownum colnum budget acct rollup-budget?
column-list exchange-fn)
(let* ((current-col (+ colnum 1))
- (bgt-total (gnc-numeric-zero))
+ (bgt-total 0)
(bgt-total-unset? #t)
- (act-total (gnc-numeric-zero))
+ (act-total 0)
(comm (xaccAccountGetCommodity acct))
(reverse-balance? (gnc-reverse-balance acct))
(income-acct? (eq? (xaccAccountGetType acct) ACCT-TYPE-INCOME)))
@@ -397,7 +393,7 @@
(style-tag-neg (string-append style-tag "-neg")))
(if show-budget?
(begin
- (set! bgt-val (if (gnc-numeric-zero-p bgt-numeric-val) "."
+ (set! bgt-val (if (zero? bgt-numeric-val) "."
(gnc:make-gnc-monetary comm bgt-numeric-val)))
(gnc:html-table-set-cell/tag!
html-table rownum current-col style-tag bgt-val)
@@ -407,7 +403,7 @@
(set! act-val (gnc:make-gnc-monetary comm act-numeric-val))
(gnc:html-table-set-cell/tag!
html-table rownum current-col
- (if (gnc-numeric-negative-p act-numeric-val)
+ (if (negative? act-numeric-val)
style-tag-neg
style-tag)
act-val)
@@ -415,13 +411,13 @@
(if show-diff?
(begin
(set! dif-val
- (if (and (gnc-numeric-zero-p bgt-numeric-val)
- (gnc-numeric-zero-p act-numeric-val))
+ (if (and (zero? bgt-numeric-val)
+ (zero? act-numeric-val))
"."
(gnc:make-gnc-monetary comm dif-numeric-val)))
(gnc:html-table-set-cell/tag!
html-table rownum current-col
- (if (gnc-numeric-negative-p dif-numeric-val)
+ (if (negative? dif-numeric-val)
style-tag-neg
style-tag)
dif-val)
@@ -446,27 +442,21 @@
budget acct period-list))
(act-numeric-val
(if reverse-balance?
- (gnc-numeric-neg act-numeric-abs)
+ (- act-numeric-abs)
act-numeric-abs))
;; difference (budget to actual)
(dif-numeric-val
- (gnc-numeric-sub
- bgt-numeric-val act-numeric-val
- GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER))))
+ (- bgt-numeric-val act-numeric-val)))
- (if (not (gnc-numeric-zero-p bgt-numeric-val))
+ (if (not (zero? bgt-numeric-val))
(begin
- (set! bgt-total (gnc-numeric-add bgt-total bgt-numeric-val
- GNC-DENOM-AUTO GNC-RND-ROUND))
+ (set! bgt-total (+ bgt-total bgt-numeric-val))
(set! bgt-total-unset? #f)))
- (set! act-total (gnc-numeric-add act-total act-numeric-val
- GNC-DENOM-AUTO GNC-RND-ROUND))
+ (set! act-total (+ act-total act-numeric-val))
(if income-acct?
(set! dif-numeric-val
- (gnc-numeric-sub
- act-numeric-val bgt-numeric-val
- GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER))))
+ (- act-numeric-val bgt-numeric-val)))
(gnc:html-table-display-budget-columns!
html-table rownum #f
bgt-numeric-val act-numeric-val dif-numeric-val)))
@@ -478,12 +468,8 @@
(gnc:html-table-display-budget-columns!
html-table rownum #t bgt-total act-total
(if income-acct?
- (gnc-numeric-sub
- act-total bgt-total
- GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER))
- (gnc-numeric-sub
- bgt-total act-total
- GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER)))))
+ (- act-total bgt-total)
+ (- bgt-total act-total))))
((list? col-info)
(gnc:html-table-add-budget-line-columns!
html-table rownum budget acct col-info))
commit 9d38d7fa8e91681b05f11dd96441da18519e4bab
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Mar 2 20:58:53 2019 +0800
[budget] compact find-period-relative-to-current
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index 80dbe2c84..75ffe741b 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -580,25 +580,20 @@
;; adjuster - function that is used for calculation of period relative to current
(define (find-period-relative-to-current budget adjuster)
(let* ((now (current-time))
- (total-periods (gnc-budget-get-num-periods budget) )
- (last-period (- total-periods 1))
+ (total-periods (gnc-budget-get-num-periods budget))
+ (last-period (1- total-periods))
(period-start (lambda (x) (gnc-budget-get-period-start-date budget x)))
(period-end (lambda (x) (gnc-budget-get-period-end-date budget x))))
(cond ((< now (period-start 0)) 1)
((> now (period-end last-period)) total-periods)
- ( else (let ((found-period
- (find (lambda (period)
- (and (>= now (period-start period))
- (<= now (period-end period))))
- (iota total-periods))))
- (gnc:debug "current period =" found-period)
- (if found-period
- (let ((adjusted (adjuster found-period)))
- (cond
- ((< adjusted 0) 0)
- ((> adjusted last-period) last-period)
- (else adjusted)))
- #f))))))
+ (else (let ((found-period
+ (find (lambda (period)
+ (<= (period-start period)
+ now
+ (period-end period)))
+ (iota total-periods))))
+ (and found-period
+ (max 0 (min last-period (adjuster found-period)))))))))
;; Maps type of user selected period to concrete period number, if
;; user not selected to use range false is returned
(define (calc-user-period budget use-ranges? period-type period-exact-val)
commit cd496cbe3ccc89381d69a0cc3c81e8ee81aecf11
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Mar 2 20:54:55 2019 +0800
[budget] compact calc-user-period
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index 767184384..80dbe2c84 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -601,23 +601,15 @@
#f))))))
;; Maps type of user selected period to concrete period number, if
;; user not selected to use range false is returned
- (define (calc-user-period budget
- use-ranges? period-type period-exact-val)
- (if (not use-ranges?)
- #f
- (cond
- ((eq? 'first period-type) 0)
- ((eq? 'last period-type) (- (gnc-budget-get-num-periods budget) 1))
- ((eq? 'manual period-type) (- period-exact-val 1))
- ((eq? 'previous period-type)
- (find-period-relative-to-current budget (lambda (period)
- (- period 1))))
- ((eq? 'current period-type)
- (find-period-relative-to-current budget (lambda (period)
- period)))
- ((eq? 'next period-type)
- (find-period-relative-to-current budget (lambda (period)
- (+ period 1)))))))
+ (define (calc-user-period budget use-ranges? period-type period-exact-val)
+ (and use-ranges?
+ (case period-type
+ ((first) 0)
+ ((last) (1- (gnc-budget-get-num-periods budget)))
+ ((manual) (1- period-exact-val))
+ ((previous) (find-period-relative-to-current budget 1-))
+ ((current) (find-period-relative-to-current budget identity))
+ ((next) (find-period-relative-to-current budget 1+)))))
;; Performs calculation of periods list. If list element is a list
;; itself, it means that elements of this sublist should be
;; presented as summed value. If user required a total column
commit c8625ab5fb75d0cf28bbab1770f42cf016655e42
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Mar 2 20:07:16 2019 +0800
[budget] *reindent/untabify/delete-trailing-whitespace*
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index b3513d149..767184384 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -27,7 +27,7 @@
(define-module (gnucash report standard-reports budget))
-(use-modules (gnucash utilities))
+(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
@@ -100,47 +100,41 @@
;;List of common helper functions, that is not bound only to options generation or report evaluation
(define (get-option-val options pagename optname)
- (gnc:option-value
- (gnc:lookup-option options pagename optname)))
+ (gnc:option-value
+ (gnc:lookup-option options pagename optname)))
-(define (set-option-enabled options page opt-name enabled)
- (gnc-option-db-set-option-selectable-by-name
- options page opt-name enabled))
+(define (set-option-enabled options page opt-name enabled)
+ (gnc-option-db-set-option-selectable-by-name
+ options page opt-name enabled))
;; options generator
(define (budget-report-options-generator)
- (let* ( (options (gnc:new-options))
- (add-option
- (lambda (new-option)
- (gnc:register-option options new-option)))
- (period-options (list (list->vector
- (list 'first
- (N_ "First")
- (N_ "The first period of the budget")))
- (list->vector
- (list 'previous
- (N_ "Previous")
- (N_ "Budget period was before current period, according to report evaluation date")))
- (list->vector
- (list 'current
- (N_ "Current")
- (N_ "Current period, according to report evaluation date")))
- (list->vector
- (list 'next
- (N_ "Next")
- (N_ "Next period, according to report evaluation date")))
- (list->vector
- (list 'last
- (N_ "Last")
- (N_ "Last budget period")))
- (list->vector
- (list 'manual
- (N_ "Manual period selection")
- (N_ "Explicitly select period value with spinner below")))))
- (ui-use-periods #f)
- (ui-start-period-type 'current)
- (ui-end-period-type 'next)
- )
+ (let* ((options (gnc:new-options))
+ (add-option
+ (lambda (new-option)
+ (gnc:register-option options new-option)))
+ (period-options
+ (list (vector 'first
+ (N_ "First")
+ (N_ "The first period of the budget"))
+ (vector 'previous
+ (N_ "Previous")
+ (N_ "Budget period was before current period, according to report evaluation date"))
+ (vector 'current
+ (N_ "Current")
+ (N_ "Current period, according to report evaluation date"))
+ (vector 'next
+ (N_ "Next")
+ (N_ "Next period, according to report evaluation date"))
+ (vector 'last
+ (N_ "Last")
+ (N_ "Last budget period"))
+ (vector 'manual
+ (N_ "Manual period selection")
+ (N_ "Explicitly select period value with spinner below"))))
+ (ui-use-periods #f)
+ (ui-start-period-type 'current)
+ (ui-end-period-type 'next))
(gnc:register-option
options
@@ -148,20 +142,9 @@
gnc:pagename-general optname-budget
"a" (N_ "Budget to use.")))
- ;; date interval
- ;;(gnc:options-add-date-interval!
- ;; options gnc:pagename-general
- ;; optname-from-date optname-to-date "a")
-
(gnc:options-add-price-source!
options gnc:pagename-general optname-price-source "c" 'pricedb-nearest)
- ;;(gnc:register-option
- ;; options
- ;; (gnc:make-simple-boolean-option
- ;; gnc:pagename-general optname-show-rates
- ;; "d" (N_ "Show the exchange rates used") #f))
-
(gnc:register-option
options
(gnc:make-simple-boolean-option
@@ -180,23 +163,21 @@
;; selectable only when we are running the report for a budget period
;; range.
(lambda (value)
- (let (
- (enabler (lambda (target-opt enabled)
- (set-option-enabled options gnc:pagename-general target-opt enabled)))
- )
- (for-each (lambda (target-opt)
- (enabler target-opt value))
- (list optname-budget-period-start optname-budget-period-end
- optname-period-collapse-before optname-period-collapse-after)
- )
- (enabler optname-budget-period-start-exact
- (and value
- (eq? 'manual ui-start-period-type)))
- (enabler optname-budget-period-end-exact
- (and value
- (eq? 'manual ui-end-period-type)))
- (set! ui-use-periods value)
- ))))
+ (let ((enabler (lambda (target-opt enabled)
+ (set-option-enabled
+ options gnc:pagename-general target-opt enabled))))
+ (for-each
+ (lambda (target-opt)
+ (enabler target-opt value))
+ (list optname-budget-period-start optname-budget-period-end
+ optname-period-collapse-before optname-period-collapse-after))
+ (enabler optname-budget-period-start-exact
+ (and value
+ (eq? 'manual ui-start-period-type)))
+ (enabler optname-budget-period-end-exact
+ (and value
+ (eq? 'manual ui-end-period-type)))
+ (set! ui-use-periods value)))))
(add-option
(gnc:make-multichoice-callback-option
@@ -205,13 +186,11 @@
period-options
#f
(lambda (new-val)
- (set-option-enabled options gnc:pagename-general
- optname-budget-period-start-exact
- (and ui-use-periods (eq? 'manual new-val)))
- (set! ui-start-period-type new-val)
- )
- ))
-
+ (set-option-enabled options gnc:pagename-general
+ optname-budget-period-start-exact
+ (and ui-use-periods (eq? 'manual new-val)))
+ (set! ui-start-period-type new-val))))
+
(add-option
(gnc:make-number-range-option
gnc:pagename-general optname-budget-period-start-exact
@@ -220,7 +199,7 @@
;; defined globally somewhere so we could reference it here. However, it
;; only appears to be defined currently in src/gnome/glade/budget.glade.
1 1 60 0 1))
-
+
(add-option
(gnc:make-multichoice-callback-option
gnc:pagename-general optname-budget-period-end
@@ -228,13 +207,11 @@
period-options
#f
(lambda (new-val)
- (set-option-enabled options gnc:pagename-general
- optname-budget-period-end-exact
- (and ui-use-periods (eq? 'manual new-val)))
- (set! ui-end-period-type new-val)
- )
- ))
-
+ (set-option-enabled options gnc:pagename-general
+ optname-budget-period-end-exact
+ (and ui-use-periods (eq? 'manual new-val)))
+ (set! ui-end-period-type new-val))))
+
(add-option
(gnc:make-number-range-option
gnc:pagename-general optname-budget-period-end-exact
@@ -262,7 +239,7 @@
(lambda ()
(gnc:filter-accountlist-type
(list ACCT-TYPE-ASSET ACCT-TYPE-LIABILITY ACCT-TYPE-INCOME
- ACCT-TYPE-EXPENSE)
+ ACCT-TYPE-EXPENSE)
(gnc-account-get-descendants-sorted (gnc-get-current-root-account))))
#f)
(add-option
@@ -296,11 +273,10 @@
gnc:pagename-display optname-show-zb-accounts
"s5" opthelp-show-zb-accounts #t))
- ;; Set the general page as default option tab
+ ;; Set the general page as default option tab
(gnc:options-set-default-section options gnc:pagename-general)
- options)
- )
+ options))
;; Create the html table for the budget report
;;
@@ -322,449 +298,407 @@
(num-rows (gnc:html-acct-table-num-rows acct-table))
(rownum 0)
(numcolumns (gnc:html-table-num-columns html-table))
- ;;(html-table (or html-table (gnc:make-html-table)))
+ ;;(html-table (or html-table (gnc:make-html-table)))
;; WARNING: we implicitly depend here on the details of
;; gnc:html-table-add-account-balances. Specifically, we
;; assume that it makes twice as many columns as it uses for
- ;; account labels. For now, that seems to be a valid
+ ;; account labels. For now, that seems to be a valid
;; assumption.
- (colnum (quotient numcolumns 2))
-
- )
-
- (define (negative-numeric-p x)
- (if (gnc-numeric-p x) (gnc-numeric-negative-p x) #f))
- (define (number-cell-tag x)
- (if (negative-numeric-p x) "number-cell-neg" "number-cell"))
- (define (total-number-cell-tag x)
- (if (negative-numeric-p x) "total-number-cell-neg" "total-number-cell"))
-
- ;; Calculate the value to use for the budget of an account for a specific set of periods.
- ;; If there is 1 period, use that period's budget value. Otherwise, sum the budgets for
- ;; all of the periods.
- ;;
- ;; Parameters:
- ;; budget - budget to use
- ;; acct - account
- ;; periodlist - list of budget periods to use
- ;;
- ;; Return value:
- ;; Budget sum
- (define (gnc:get-account-periodlist-budget-value budget acct periodlist)
- (cond
- ((= (length periodlist) 1) (gnc:get-account-period-rolledup-budget-value budget acct (car periodlist)))
- (else (gnc-numeric-add (gnc:get-account-period-rolledup-budget-value budget acct (car periodlist))
- (gnc:get-account-periodlist-budget-value budget acct (cdr periodlist))
- GNC-DENOM-AUTO GNC-RND-ROUND))
- )
- )
-
- ;; Calculate the value to use for the actual of an account for a specific set of periods.
- ;; This is the sum of the actuals for each of the periods.
- ;;
- ;; Parameters:
- ;; budget - budget to use
- ;; acct - account
- ;; periodlist - list of budget periods to use
- ;;
- ;; Return value:
- ;; Budget sum
- (define (gnc:get-account-periodlist-actual-value budget acct periodlist)
- (cond
- ((= (length periodlist) 1)
- (gnc-budget-get-account-period-actual-value budget acct (car periodlist)))
- (else
- (gnc-numeric-add
- (gnc-budget-get-account-period-actual-value budget acct (car periodlist))
- (gnc:get-account-periodlist-actual-value budget acct (cdr periodlist))
- GNC-DENOM-AUTO GNC-RND-ROUND))
- )
- )
-
- ;; Adds a line to tbe budget report.
- ;;
- ;; Parameters:
- ;; html-table - html table being created
- ;; rownum - row number
- ;; colnum - starting column number
- ;; budget - budget to use
- ;; acct - account being displayed
- ;; rollup-budget? - rollup budget values for account children if account budget not set
- ;; exchange-fn - exchange function (not used)
- (define (gnc:html-table-add-budget-line!
- html-table rownum colnum budget acct rollup-budget? column-list exchange-fn)
- (let* (
- (current-col (+ colnum 1))
- (bgt-total (gnc-numeric-zero))
- (bgt-total-unset? #t)
- (act-total (gnc-numeric-zero))
- (comm (xaccAccountGetCommodity acct))
- (reverse-balance? (gnc-reverse-balance acct))
- (income-acct? (eq? (xaccAccountGetType acct) ACCT-TYPE-INCOME))
- )
-
- ;; Displays a set of budget column values
- ;;
- ;; Parameters
- ;; html-table - html table being created
- ;; rownum - row number
- ;; total? - is this a set of total columns
- ;; bgt-numeric-val - budget value, or #f if column not to be shown
- ;; act-numeric-val - actual value, or #f if column not to be shown
- ;; dif-numeric val - difference value, or #f if column not to be shown
- (define (gnc:html-table-display-budget-columns!
- html-table rownum total? bgt-numeric-val act-numeric-val dif-numeric-val)
- (let* ((bgt-val #f)(act-val #f)(dif-val #f)
- (style-tag (if total? "total-number-cell" "number-cell"))
- (style-tag-neg (string-append style-tag "-neg"))
- )
- (if show-budget?
- (begin
- (set! bgt-val (if (gnc-numeric-zero-p bgt-numeric-val) "."
- (gnc:make-gnc-monetary comm bgt-numeric-val)))
- (gnc:html-table-set-cell/tag!
- html-table rownum current-col style-tag bgt-val)
- (set! current-col (+ current-col 1))
- )
- )
- (if show-actual?
- (begin
- (set! act-val (gnc:make-gnc-monetary comm act-numeric-val))
- (gnc:html-table-set-cell/tag!
- html-table rownum current-col
- (if (gnc-numeric-negative-p act-numeric-val) style-tag-neg style-tag)
- act-val)
- (set! current-col (+ current-col 1))
- )
- )
- (if show-diff?
- (begin
- (set! dif-val
- (if (and (gnc-numeric-zero-p bgt-numeric-val) (gnc-numeric-zero-p act-numeric-val))
- "."
- (gnc:make-gnc-monetary comm dif-numeric-val)))
- (gnc:html-table-set-cell/tag!
- html-table rownum current-col
- (if (gnc-numeric-negative-p dif-numeric-val) style-tag-neg style-tag)
- dif-val)
- (set! current-col (+ current-col 1))
- )
- )
- )
- );;end of define gnc:html-table-display-budget-columns
-
- ;; Adds a set of column values to the budget report for a specific list
- ;; of periods.
- ;;
- ;; Parameters:
- ;; html-table - html table being created
- ;; rownum - row number
- ;; budget - budget to use
- ;; acct - account being displayed
- ;; period-list - list of periods to use
- (define (gnc:html-table-add-budget-line-columns!
- html-table rownum budget acct period-list)
- (let* (
- ;; budgeted amount
- (bgt-numeric-val (gnc:get-account-periodlist-budget-value budget acct period-list))
-
- ;; actual amount
- (act-numeric-abs (gnc:get-account-periodlist-actual-value budget acct period-list))
- (act-numeric-val
- (if reverse-balance?
- (gnc-numeric-neg act-numeric-abs)
- act-numeric-abs))
-
- ;; difference (budget to actual)
- (dif-numeric-val
- (gnc-numeric-sub
- bgt-numeric-val act-numeric-val
- GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER)))
- )
-
- (if (not (gnc-numeric-zero-p bgt-numeric-val))
- (begin
- (set! bgt-total (gnc-numeric-add bgt-total bgt-numeric-val GNC-DENOM-AUTO GNC-RND-ROUND))
- (set! bgt-total-unset? #f))
- )
- (set! act-total (gnc-numeric-add act-total act-numeric-val GNC-DENOM-AUTO GNC-RND-ROUND))
- (if income-acct?
- (set! dif-numeric-val
- (gnc-numeric-sub
- act-numeric-val bgt-numeric-val
- GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER))))
- (gnc:html-table-display-budget-columns!
- html-table rownum #f
- bgt-numeric-val act-numeric-val dif-numeric-val)
- )
- );;end of define gnc:html-table-add-budget-line-columns
-
- (while (not (null? column-list))
- (let* ((col-info (car column-list)))
- (cond
- ((equal? col-info 'total)
- (gnc:html-table-display-budget-columns!
- html-table rownum #t bgt-total act-total
- (if income-acct?
- (gnc-numeric-sub
- act-total bgt-total
- GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER))
- (gnc-numeric-sub
- bgt-total act-total
- GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER)))
- ))
- ((list? col-info)
- (gnc:html-table-add-budget-line-columns! html-table rownum budget acct col-info))
- (else
- (gnc:html-table-add-budget-line-columns! html-table rownum budget acct (list col-info)))
- )
- (set! column-list (cdr column-list))
- )
- )
- )
- );; end of define gnc:html-table-add-budget-line
-
- ;; Adds header rows to the budget report. The columns are specified by the
- ;; column-list parameter.
- ;;
- ;; Parameters:
- ;; html-table - html table being created
- ;; colnum - starting column number
- ;; budget - budget to use
- ;; column-list - column info list
- (define (gnc:html-table-add-budget-headers!
- html-table colnum budget column-list)
- (let* (
- (current-col (+ colnum 1))
- (col-list column-list)
- (col-span 0)
- )
-
- (if show-budget? (set! col-span (+ col-span 1)))
- (if show-actual? (set! col-span (+ col-span 1)))
- (if show-diff? (set! col-span (+ col-span 1)))
- (if (eqv? col-span 0) (set! col-span 1))
-
- ;; prepend 2 empty rows
- (gnc:html-table-prepend-row! html-table '())
- (gnc:html-table-prepend-row! html-table '())
-
- (while (not (= (length col-list) 0))
- (let* (
- (col-info (car col-list))
- (tc #f)
- (period-to-date-string (lambda (p) (qof-print-date (gnc-budget-get-period-start-date budget p))))
- )
- (cond
- ((equal? col-info 'total)
- (gnc:html-table-set-cell! html-table 0 current-col (_ "Total"))
- )
- ((list? col-info)
- (gnc:html-table-set-cell!
- html-table 0 current-col (string-append
- (period-to-date-string (car col-info))
- " – "
- (period-to-date-string (car (reverse col-info)))
- )
- )
- )
- (else
- (gnc:html-table-set-cell!
- html-table 0 current-col (period-to-date-string col-info)
- )
- )
- )
- (set! tc (gnc:html-table-get-cell html-table 0 current-col))
- (gnc:html-table-cell-set-colspan! tc col-span)
- (gnc:html-table-cell-set-tag! tc "centered-label-cell")
- (set! current-col (+ current-col 1))
- (set! col-list (cdr col-list))
- )
- )
-
- ;; make the column headers
- (set! col-list column-list)
- (set! current-col (+ colnum 1))
- (while (not (= (length column-list) 0))
- (let* ((col-info (car column-list)))
- (if show-budget?
- (begin
- (gnc:html-table-set-cell/tag!
- html-table 1 current-col "centered-label-cell"
- (_ "Bgt")) ;; Translators: Abbreviation for "Budget"
- (set! current-col (+ current-col 1))
- )
- )
- (if show-actual?
- (begin
- (gnc:html-table-set-cell/tag!
- html-table 1 current-col "centered-label-cell"
- (_ "Act")) ;; Translators: Abbreviation for "Actual"
- (set! current-col (+ current-col 1))
- )
- )
- (if show-diff?
- (begin
- (gnc:html-table-set-cell/tag!
- html-table 1 current-col "centered-label-cell"
- (_ "Diff")) ;; Translators: Abbreviation for "Difference"
- (set! current-col (+ current-col 1))
- )
- )
- (set! column-list (cdr column-list))
- )
- )
- )
- );;end of define gnc:html-table-add-budget-headers
-
- ;; Determines the budget period relative to current period. Budget period is current if
- ;; it start time <= current time and end time >= current time
- ;; When period is found it's passed to adjuster that is responsible for final calculation of period.
- ;;
- ;; If budget in future then first period of bundget is returned, if it in past, then the last period is returned
- ;; if adjuster produced period number that is less then first period or greater than last period, the same rules apply.
+ (colnum (quotient numcolumns 2)))
+
+ (define (negative-numeric-p x)
+ (if (gnc-numeric-p x) (gnc-numeric-negative-p x) #f))
+ (define (number-cell-tag x)
+ (if (negative-numeric-p x) "number-cell-neg" "number-cell"))
+ (define (total-number-cell-tag x)
+ (if (negative-numeric-p x) "total-number-cell-neg" "total-number-cell"))
+
+ ;; Calculate the value to use for the budget of an account for a
+ ;; specific set of periods. If there is 1 period, use that
+ ;; period's budget value. Otherwise, sum the budgets for all of
+ ;; the periods.
+ ;;
+ ;; Parameters:
+ ;; budget - budget to use
+ ;; acct - account
+ ;; periodlist - list of budget periods to use
+ ;;
+ ;; Return value:
+ ;; Budget sum
+ (define (gnc:get-account-periodlist-budget-value budget acct periodlist)
+ (cond
+ ((= (length periodlist) 1)
+ (gnc:get-account-period-rolledup-budget-value budget acct (car periodlist)))
+ (else
+ (gnc-numeric-add
+ (gnc:get-account-period-rolledup-budget-value budget acct (car periodlist))
+ (gnc:get-account-periodlist-budget-value budget acct (cdr periodlist))
+ GNC-DENOM-AUTO GNC-RND-ROUND))))
+
+ ;; Calculate the value to use for the actual of an account for a
+ ;; specific set of periods. This is the sum of the actuals for
+ ;; each of the periods.
+ ;;
+ ;; Parameters:
+ ;; budget - budget to use
+ ;; acct - account
+ ;; periodlist - list of budget periods to use
+ ;;
+ ;; Return value:
+ ;; Budget sum
+ (define (gnc:get-account-periodlist-actual-value budget acct periodlist)
+ (cond
+ ((= (length periodlist) 1)
+ (gnc-budget-get-account-period-actual-value budget acct (car periodlist)))
+ (else
+ (gnc-numeric-add
+ (gnc-budget-get-account-period-actual-value budget acct (car periodlist))
+ (gnc:get-account-periodlist-actual-value budget acct (cdr periodlist))
+ GNC-DENOM-AUTO GNC-RND-ROUND))))
+
+ ;; Adds a line to tbe budget report.
+ ;;
+ ;; Parameters:
+ ;; html-table - html table being created
+ ;; rownum - row number
+ ;; colnum - starting column number
+ ;; budget - budget to use
+ ;; acct - account being displayed
+ ;; rollup-budget? - rollup budget values for account children
+ ;; if account budget not set
+ ;; exchange-fn - exchange function (not used)
+ (define (gnc:html-table-add-budget-line!
+ html-table rownum colnum budget acct rollup-budget?
+ column-list exchange-fn)
+ (let* ((current-col (+ colnum 1))
+ (bgt-total (gnc-numeric-zero))
+ (bgt-total-unset? #t)
+ (act-total (gnc-numeric-zero))
+ (comm (xaccAccountGetCommodity acct))
+ (reverse-balance? (gnc-reverse-balance acct))
+ (income-acct? (eq? (xaccAccountGetType acct) ACCT-TYPE-INCOME)))
+
+ ;; Displays a set of budget column values
+ ;;
+ ;; Parameters
+ ;; html-table - html table being created
+ ;; rownum - row number
+ ;; total? - is this a set of total columns
+ ;; bgt-numeric-val - budget value, or #f if column not to be shown
+ ;; act-numeric-val - actual value, or #f if column not to be shown
+ ;; dif-numeric val - difference value, or #f if column not to be shown
+ (define (gnc:html-table-display-budget-columns!
+ html-table rownum total? bgt-numeric-val act-numeric-val
+ dif-numeric-val)
+ (let* ((bgt-val #f)
+ (act-val #f)
+ (dif-val #f)
+ (style-tag (if total? "total-number-cell" "number-cell"))
+ (style-tag-neg (string-append style-tag "-neg")))
+ (if show-budget?
+ (begin
+ (set! bgt-val (if (gnc-numeric-zero-p bgt-numeric-val) "."
+ (gnc:make-gnc-monetary comm bgt-numeric-val)))
+ (gnc:html-table-set-cell/tag!
+ html-table rownum current-col style-tag bgt-val)
+ (set! current-col (+ current-col 1))))
+ (if show-actual?
+ (begin
+ (set! act-val (gnc:make-gnc-monetary comm act-numeric-val))
+ (gnc:html-table-set-cell/tag!
+ html-table rownum current-col
+ (if (gnc-numeric-negative-p act-numeric-val)
+ style-tag-neg
+ style-tag)
+ act-val)
+ (set! current-col (+ current-col 1))))
+ (if show-diff?
+ (begin
+ (set! dif-val
+ (if (and (gnc-numeric-zero-p bgt-numeric-val)
+ (gnc-numeric-zero-p act-numeric-val))
+ "."
+ (gnc:make-gnc-monetary comm dif-numeric-val)))
+ (gnc:html-table-set-cell/tag!
+ html-table rownum current-col
+ (if (gnc-numeric-negative-p dif-numeric-val)
+ style-tag-neg
+ style-tag)
+ dif-val)
+ (set! current-col (+ current-col 1))))))
+
+ ;; Adds a set of column values to the budget report for a specific list
+ ;; of periods.
;;
;; Parameters:
+ ;; html-table - html table being created
+ ;; rownum - row number
;; budget - budget to use
- ;; adjuster - function that is used for calculation of period relative to current
- (define (find-period-relative-to-current budget adjuster)
- (let* ((now (current-time))
- (total-periods (gnc-budget-get-num-periods budget) )
- (last-period (- total-periods 1))
- (period-start (lambda (x) (gnc-budget-get-period-start-date budget x)))
- (period-end (lambda (x) (gnc-budget-get-period-end-date budget x)))
- )
- (cond ((< now (period-start 0)) 1)
- ((> now (period-end last-period)) total-periods)
- ( else (let ((found-period
- (find (lambda (period)
- (and (>= now (period-start period))
- (<= now (period-end period))))
- (iota total-periods))
- ))
- (gnc:debug "current period =" found-period)
- (if found-period
- (let ((adjusted (adjuster found-period)))
- (cond ((< adjusted 0) 0) ((> adjusted last-period) last-period) (else adjusted))
- )
- #f)
- ))
- )
- )
- );;end of find-period-relative-to-current
- ;; Maps type of user selected period to concrete period number, if user not selected to use range false is returned
- (define (calc-user-period budget
- use-ranges? period-type period-exact-val )
- (if (not use-ranges?)
- #f
- (cond
- ((eq? 'first period-type) 0)
- ((eq? 'last period-type) (- (gnc-budget-get-num-periods budget) 1))
- ((eq? 'manual period-type) (- period-exact-val 1))
- ((eq? 'previous period-type)
- (find-period-relative-to-current budget (lambda (period) (- period 1))))
- ((eq? 'current period-type)
- (find-period-relative-to-current budget (lambda (period) period )))
- ((eq? 'next period-type)
- (find-period-relative-to-current budget (lambda (period) ( + period 1))))
- )
- )
- );;end of calc-user-period budget
- ;; Performs calculation of periods list. If list element is a list itself, it means that
- ;; elements of this sublist should be presented as summed value.
- ;; If user required a total column calculation a quoted total val appended to the end
- ;; For example if function produced list ( (0 1 2 3 4) 5 6 7 (8 9) 'total) then budget report will
- ;; have 6 columns:
- ;; -- first column is a sum of values for periods 0..4
- ;; -- second .. forth columns is a values for periods 5,6,7
- ;; -- fifth is a sum of value for periods 8, 9
- ;; -- sixth a column with total of all columns
- ;;
- ;; Total is calculated only for selected periods. So if the list resulted in (3 4 'total), total column
- ;; will contain the sum of values for periods 3,4
- (define (calc-periods
- budget user-start user-end collapse-before? collapse-after? show-total?)
-
-
- (define (range start end)
- (define (int-range current end step lst)
- (if (>= current end)
- lst
- (int-range (+ current step) end step (cons current lst))))
- (reverse (int-range (if (number? start) start 0) end 1 '()))
- )
-
- (let* ((num-periods (gnc-budget-get-num-periods budget))
- (range-start (if user-start user-start 0))
- (range-end (if user-end (+ 1 user-end) num-periods))
- (fold-before-start 0)
- (fold-before-end (if collapse-before? range-start 0))
- (fold-after-start (if collapse-after? range-end num-periods))
- (fold-after-end num-periods)
- )
- (map (lambda (x) (if (and (list? x) (= 1 (length x))) (car x) x))
- (filter (lambda (x) (not (null? x)))
- (append (list (range fold-before-start fold-before-end))
- (range range-start range-end)
- (list (range fold-after-start fold-after-end))
- (if show-total? (list 'total) '())
- )))
- )
- );;end of define calc-periods
-
- ;; end of defines
-
-
- (let* ((rownum 0)
- (use-ranges? (get-val params 'use-ranges))
- (column-info-list (calc-periods budget
- (calc-user-period budget
- use-ranges?
- (get-val params 'user-start-period)
- (get-val params 'user-start-period-exact)
- )
- (calc-user-period budget
- use-ranges?
- (get-val params 'user-end-period)
- (get-val params 'user-end-period-exact)
- )
- (get-val params 'collapse-before)
- (get-val params 'collapse-after)
- show-totalcol?
- ))
- ;;(html-table (or html-table (gnc:make-html-table)))
- ;; WARNING: we implicitly depend here on the details of
- ;; gnc:html-table-add-account-balances. Specifically, we
- ;; assume that it makes twice as many columns as it uses for
- ;; account labels. For now, that seems to be a valid
- ;; assumption.
- )
- ;;debug output for control of period list calculation
- (gnc:debug "use-ranges? =" use-ranges?)
- (gnc:debug "user-start-period =" (get-val params 'user-start-period))
- (gnc:debug "user-start-period-exact =" (get-val params 'user-start-period-exact))
- (gnc:debug "user-end-period =" (get-val params 'user-end-period))
- (gnc:debug "user-end-period-exact =" (get-val params 'user-end-period-exact))
- (gnc:debug "column-info-list=" column-info-list)
-
- ;; call gnc:html-table-add-budget-line! for each account
- (while (< rownum num-rows)
- (let* (
- (env (append (gnc:html-acct-table-get-row-env acct-table rownum) params))
- (acct (get-val env 'account))
- (exchange-fn (get-val env 'exchange-fn))
- )
- (gnc:html-table-add-budget-line!
- html-table rownum colnum budget acct rollup-budget? column-info-list exchange-fn)
- (set! rownum (+ rownum 1)) ;; increment rownum
- )
- ) ;; end of while
-
- ;; column headers
- (gnc:html-table-add-budget-headers! html-table colnum budget column-info-list)
- )
- )
-) ;; end of define gnc:html-table-add-budget-values
+ ;; acct - account being displayed
+ ;; period-list - list of periods to use
+ (define (gnc:html-table-add-budget-line-columns!
+ html-table rownum budget acct period-list)
+ (let* (;; budgeted amount
+ (bgt-numeric-val (gnc:get-account-periodlist-budget-value
+ budget acct period-list))
+ ;; actual amount
+ (act-numeric-abs (gnc:get-account-periodlist-actual-value
+ budget acct period-list))
+ (act-numeric-val
+ (if reverse-balance?
+ (gnc-numeric-neg act-numeric-abs)
+ act-numeric-abs))
+
+ ;; difference (budget to actual)
+ (dif-numeric-val
+ (gnc-numeric-sub
+ bgt-numeric-val act-numeric-val
+ GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER))))
+
+ (if (not (gnc-numeric-zero-p bgt-numeric-val))
+ (begin
+ (set! bgt-total (gnc-numeric-add bgt-total bgt-numeric-val
+ GNC-DENOM-AUTO GNC-RND-ROUND))
+ (set! bgt-total-unset? #f)))
+ (set! act-total (gnc-numeric-add act-total act-numeric-val
+ GNC-DENOM-AUTO GNC-RND-ROUND))
+ (if income-acct?
+ (set! dif-numeric-val
+ (gnc-numeric-sub
+ act-numeric-val bgt-numeric-val
+ GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER))))
+ (gnc:html-table-display-budget-columns!
+ html-table rownum #f
+ bgt-numeric-val act-numeric-val dif-numeric-val)))
+
+ (while (not (null? column-list))
+ (let* ((col-info (car column-list)))
+ (cond
+ ((equal? col-info 'total)
+ (gnc:html-table-display-budget-columns!
+ html-table rownum #t bgt-total act-total
+ (if income-acct?
+ (gnc-numeric-sub
+ act-total bgt-total
+ GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER))
+ (gnc-numeric-sub
+ bgt-total act-total
+ GNC-DENOM-AUTO (+ GNC-DENOM-LCD GNC-RND-NEVER)))))
+ ((list? col-info)
+ (gnc:html-table-add-budget-line-columns!
+ html-table rownum budget acct col-info))
+ (else
+ (gnc:html-table-add-budget-line-columns!
+ html-table rownum budget acct (list col-info))))
+ (set! column-list (cdr column-list))))))
+
+ ;; Adds header rows to the budget report. The columns are
+ ;; specified by the column-list parameter.
+ ;;
+ ;; Parameters:
+ ;; html-table - html table being created
+ ;; colnum - starting column number
+ ;; budget - budget to use
+ ;; column-list - column info list
+ (define (gnc:html-table-add-budget-headers!
+ html-table colnum budget column-list)
+ (let* ((current-col (+ colnum 1))
+ (col-list column-list)
+ (col-span 0))
+ (if show-budget? (set! col-span (+ col-span 1)))
+ (if show-actual? (set! col-span (+ col-span 1)))
+ (if show-diff? (set! col-span (+ col-span 1)))
+ (if (eqv? col-span 0) (set! col-span 1))
+
+ ;; prepend 2 empty rows
+ (gnc:html-table-prepend-row! html-table '())
+ (gnc:html-table-prepend-row! html-table '())
+
+ (while (not (= (length col-list) 0))
+ (let* ((col-info (car col-list))
+ (tc #f)
+ (period-to-date-string (lambda (p)
+ (qof-print-date
+ (gnc-budget-get-period-start-date
+ budget p)))))
+ (cond
+ ((equal? col-info 'total)
+ (gnc:html-table-set-cell! html-table 0 current-col (_ "Total")))
+ ((list? col-info)
+ (gnc:html-table-set-cell!
+ html-table 0 current-col (string-append
+ (period-to-date-string (car col-info))
+ " – "
+ (period-to-date-string
+ (car (reverse col-info))))))
+ (else
+ (gnc:html-table-set-cell!
+ html-table 0 current-col (period-to-date-string col-info))))
+ (set! tc (gnc:html-table-get-cell html-table 0 current-col))
+ (gnc:html-table-cell-set-colspan! tc col-span)
+ (gnc:html-table-cell-set-tag! tc "centered-label-cell")
+ (set! current-col (+ current-col 1))
+ (set! col-list (cdr col-list))))
+
+ ;; make the column headers
+ (set! col-list column-list)
+ (set! current-col (+ colnum 1))
+ (while (not (= (length column-list) 0))
+ (let* ((col-info (car column-list)))
+ (if show-budget?
+ (begin
+ (gnc:html-table-set-cell/tag!
+ html-table 1 current-col "centered-label-cell"
+ (_ "Bgt")) ;; Translators: Abbreviation for "Budget"
+ (set! current-col (+ current-col 1))))
+ (if show-actual?
+ (begin
+ (gnc:html-table-set-cell/tag!
+ html-table 1 current-col "centered-label-cell"
+ (_ "Act")) ;; Translators: Abbreviation for "Actual"
+ (set! current-col (+ current-col 1))))
+ (if show-diff?
+ (begin
+ (gnc:html-table-set-cell/tag!
+ html-table 1 current-col "centered-label-cell"
+ (_ "Diff")) ;; Translators: Abbreviation for "Difference"
+ (set! current-col (+ current-col 1))))
+ (set! column-list (cdr column-list))))))
+
+ ;; Determines the budget period relative to current period. Budget
+ ;; period is current if it start time <= current time and end time
+ ;; >= current time When period is found it's passed to adjuster
+ ;; that is responsible for final calculation of period.
+ ;;
+ ;; If budget in future then first period of budget is returned,
+ ;; if it in past, then the last period is returned if adjuster
+ ;; produced period number that is less then first period or
+ ;; greater than last period, the same rules apply.
+ ;;
+ ;; Parameters:
+ ;; budget - budget to use
+ ;; adjuster - function that is used for calculation of period relative to current
+ (define (find-period-relative-to-current budget adjuster)
+ (let* ((now (current-time))
+ (total-periods (gnc-budget-get-num-periods budget) )
+ (last-period (- total-periods 1))
+ (period-start (lambda (x) (gnc-budget-get-period-start-date budget x)))
+ (period-end (lambda (x) (gnc-budget-get-period-end-date budget x))))
+ (cond ((< now (period-start 0)) 1)
+ ((> now (period-end last-period)) total-periods)
+ ( else (let ((found-period
+ (find (lambda (period)
+ (and (>= now (period-start period))
+ (<= now (period-end period))))
+ (iota total-periods))))
+ (gnc:debug "current period =" found-period)
+ (if found-period
+ (let ((adjusted (adjuster found-period)))
+ (cond
+ ((< adjusted 0) 0)
+ ((> adjusted last-period) last-period)
+ (else adjusted)))
+ #f))))))
+ ;; Maps type of user selected period to concrete period number, if
+ ;; user not selected to use range false is returned
+ (define (calc-user-period budget
+ use-ranges? period-type period-exact-val)
+ (if (not use-ranges?)
+ #f
+ (cond
+ ((eq? 'first period-type) 0)
+ ((eq? 'last period-type) (- (gnc-budget-get-num-periods budget) 1))
+ ((eq? 'manual period-type) (- period-exact-val 1))
+ ((eq? 'previous period-type)
+ (find-period-relative-to-current budget (lambda (period)
+ (- period 1))))
+ ((eq? 'current period-type)
+ (find-period-relative-to-current budget (lambda (period)
+ period)))
+ ((eq? 'next period-type)
+ (find-period-relative-to-current budget (lambda (period)
+ (+ period 1)))))))
+ ;; Performs calculation of periods list. If list element is a list
+ ;; itself, it means that elements of this sublist should be
+ ;; presented as summed value. If user required a total column
+ ;; calculation a quoted total val appended to the end For example
+ ;; if function produced list ( (0 1 2 3 4) 5 6 7 (8 9) 'total)
+ ;; then budget report will have 6 columns:
+ ;; -- first column is a sum of values for periods 0..4
+ ;; -- second .. forth columns is a values for periods 5,6,7
+ ;; -- fifth is a sum of value for periods 8, 9
+ ;; -- sixth a column with total of all columns
+ ;;
+ ;; Total is calculated only for selected periods. So if the list
+ ;; resulted in (3 4 'total), total column will contain the sum of
+ ;; values for periods 3,4
+ (define (calc-periods
+ budget user-start user-end collapse-before? collapse-after? show-total?)
+ (define (range start end)
+ (define (int-range current end step lst)
+ (if (>= current end)
+ lst
+ (int-range (+ current step) end step (cons current lst))))
+ (reverse (int-range (if (number? start) start 0) end 1 '())))
+ (let* ((num-periods (gnc-budget-get-num-periods budget))
+ (range-start (if user-start user-start 0))
+ (range-end (if user-end (+ 1 user-end) num-periods))
+ (fold-before-start 0)
+ (fold-before-end (if collapse-before? range-start 0))
+ (fold-after-start (if collapse-after? range-end num-periods))
+ (fold-after-end num-periods))
+ (map (lambda (x) (if (and (list? x) (= 1 (length x))) (car x) x))
+ (filter (lambda (x) (not (null? x)))
+ (append (list (range fold-before-start fold-before-end))
+ (range range-start range-end)
+ (list (range fold-after-start fold-after-end))
+ (if show-total? (list 'total) '()))))))
+ ;; end of defines
+
+ (let* ((rownum 0)
+ (use-ranges? (get-val params 'use-ranges))
+ (column-info-list (calc-periods
+ budget
+ (calc-user-period
+ budget use-ranges?
+ (get-val params 'user-start-period)
+ (get-val params 'user-start-period-exact))
+ (calc-user-period
+ budget use-ranges?
+ (get-val params 'user-end-period)
+ (get-val params 'user-end-period-exact))
+ (get-val params 'collapse-before)
+ (get-val params 'collapse-after)
+ show-totalcol?))
+ ;;(html-table (or html-table (gnc:make-html-table)))
+ ;; WARNING: we implicitly depend here on the details of
+ ;; gnc:html-table-add-account-balances. Specifically, we
+ ;; assume that it makes twice as many columns as it uses for
+ ;; account labels. For now, that seems to be a valid
+ ;; assumption.
+ )
+ ;;debug output for control of period list calculation
+ (gnc:debug "use-ranges? =" use-ranges?)
+ (gnc:debug "user-start-period =" (get-val params 'user-start-period))
+ (gnc:debug "user-start-period-exact =" (get-val params 'user-start-period-exact))
+ (gnc:debug "user-end-period =" (get-val params 'user-end-period))
+ (gnc:debug "user-end-period-exact =" (get-val params 'user-end-period-exact))
+ (gnc:debug "column-info-list=" column-info-list)
+
+ ;; call gnc:html-table-add-budget-line! for each account
+ (while (< rownum num-rows)
+ (let* ((env (append (gnc:html-acct-table-get-row-env acct-table rownum)
+ params))
+ (acct (get-val env 'account))
+ (exchange-fn (get-val env 'exchange-fn)))
+ (gnc:html-table-add-budget-line!
+ html-table rownum colnum budget acct rollup-budget?
+ column-info-list exchange-fn)
+ (set! rownum (+ rownum 1))))
+
+ ;; column headers
+ (gnc:html-table-add-budget-headers!
+ html-table colnum budget column-info-list))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; budget-renderer
@@ -774,8 +708,8 @@
(define (budget-renderer report-obj)
(define (get-option pagename optname)
(get-option-val (gnc:report-options report-obj) pagename optname))
-;; (gnc:lookup-option
-;; (gnc:report-options report-obj) pagename optname)))
+ ;; (gnc:lookup-option
+ ;; (gnc:report-options report-obj) pagename optname)))
(gnc:report-starting reportname)
@@ -795,20 +729,19 @@
optname-show-zb-accounts))
(use-ranges? (get-option gnc:pagename-general optname-use-budget-period-range))
(include-collapse-before? (if use-ranges?
- (get-option gnc:pagename-general optname-period-collapse-before) #f))
+ (get-option gnc:pagename-general
+ optname-period-collapse-before)
+ #f))
(include-collapse-after? (if use-ranges?
- (get-option gnc:pagename-general optname-period-collapse-after) #f))
- (row-num 0) ;; ???
+ (get-option gnc:pagename-general
+ optname-period-collapse-after)
+ #f))
+ (row-num 0)
(work-done 0)
(work-to-do 0)
- ;;(report-currency (get-option gnc:pagename-general
- ;; optname-report-currency))
(show-full-names? (get-option gnc:pagename-general
optname-show-full-names))
- (doc (gnc:make-html-document))
- ;;(table (gnc:make-html-table))
- ;;(txt (gnc:make-html-text))
- )
+ (doc (gnc:make-html-document)))
;; end of defines
@@ -816,91 +749,95 @@
(if show-subaccts?
(let ((sub-accounts (gnc:acccounts-get-all-subaccounts accounts)))
(for-each
- (lambda (sub-account)
- (if (not (member sub-account accounts))
- (set! accounts (cons sub-account accounts))))
- sub-accounts)))
+ (lambda (sub-account)
+ (if (not (member sub-account accounts))
+ (set! accounts (cons sub-account accounts))))
+ sub-accounts)))
(cond
- ((null? accounts)
- ;; No accounts selected.
- (gnc:html-document-add-object!
- doc
- (gnc:html-make-no-account-warning reportname (gnc:report-id report-obj))))
- ((not budget-valid?)
- ;; No budget selected.
- (gnc:html-document-add-object!
- doc (gnc:html-make-generic-budget-warning reportname)))
- (else (begin
- (let* ((tree-depth (if (equal? display-depth 'all)
- (accounts-get-children-depth accounts)
- display-depth))
- (to-period-val (lambda (v) (inexact->exact (truncate (get-option gnc:pagename-general v)))))
- ;;(account-disp-list '())
-
- (env (list
- (list 'start-date (gnc:budget-get-start-date budget))
- (list 'end-date (gnc:budget-get-end-date budget))
- (list 'display-tree-depth tree-depth)
- (list 'depth-limit-behavior
- (if bottom-behavior 'flatten 'summarize))
- (list 'zero-balance-mode
- (if show-zb-accts? 'show-leaf-acct 'omit-leaf-acct))
- (list 'report-budget budget)
- ))
- (acct-table #f)
- (html-table (gnc:make-html-table))
- (params '())
- (paramsBudget (list
- (list 'show-actual
- (get-option gnc:pagename-display optname-show-actual))
- (list 'show-budget
- (get-option gnc:pagename-display optname-show-budget))
- (list 'show-difference
- (get-option gnc:pagename-display optname-show-difference))
- (list 'show-totalcol
- (get-option gnc:pagename-display optname-show-totalcol))
- (list 'rollup-budget
- (get-option gnc:pagename-display optname-rollup-budget))
- (list 'use-ranges use-ranges?)
- (list 'collapse-before include-collapse-before?)
- (list 'collapse-after include-collapse-after?)
- (list 'user-start-period (get-option gnc:pagename-general optname-budget-period-start))
- (list 'user-end-period (get-option gnc:pagename-general optname-budget-period-end))
- (list 'user-start-period-exact (to-period-val optname-budget-period-start-exact))
- (list 'user-end-period-exact (to-period-val optname-budget-period-end-exact))
- ))
- (report-name (get-option gnc:pagename-general
- gnc:optname-reportname))
- )
-
- (gnc:html-document-set-title!
- doc (format #f (_ "~a: ~a")
- report-name (gnc-budget-get-name budget)))
-
- (set! accounts (sort accounts account-full-name<?))
-
- (set! acct-table
- (gnc:make-html-acct-table/env/accts env accounts))
-
- ;; We do this in two steps: First the account names... the
- ;; add-account-balances will actually compute and add a
- ;; bunch of current account balances, too, but we'll
- ;; overwrite them.
- (set! html-table (gnc:html-table-add-account-balances
- #f acct-table params))
-
- ;; ... then the budget values
- (gnc:html-table-add-budget-values!
- html-table acct-table budget paramsBudget)
-
- ;; hmmm... I expected that add-budget-values would have to
- ;; clear out any unused columns to the right, out to the
- ;; table width, since the add-account-balance had put stuff
- ;; there, but it doesn't seem to matter.
-
- (gnc:html-document-add-object! doc html-table))))
- ) ;; end cond
+ ((null? accounts)
+ ;; No accounts selected.
+ (gnc:html-document-add-object!
+ doc
+ (gnc:html-make-no-account-warning reportname (gnc:report-id report-obj))))
+ ((not budget-valid?)
+ ;; No budget selected.
+ (gnc:html-document-add-object!
+ doc (gnc:html-make-generic-budget-warning reportname)))
+ (else (begin
+ (let* ((tree-depth (if (equal? display-depth 'all)
+ (accounts-get-children-depth accounts)
+ display-depth))
+ (to-period-val (lambda (v)
+ (inexact->exact
+ (truncate
+ (get-option gnc:pagename-general v)))))
+ (env (list
+ (list 'start-date (gnc:budget-get-start-date budget))
+ (list 'end-date (gnc:budget-get-end-date budget))
+ (list 'display-tree-depth tree-depth)
+ (list 'depth-limit-behavior
+ (if bottom-behavior 'flatten 'summarize))
+ (list 'zero-balance-mode
+ (if show-zb-accts? 'show-leaf-acct 'omit-leaf-acct))
+ (list 'report-budget budget)))
+ (acct-table #f)
+ (html-table (gnc:make-html-table))
+ (params '())
+ (paramsBudget
+ (list
+ (list 'show-actual
+ (get-option gnc:pagename-display optname-show-actual))
+ (list 'show-budget
+ (get-option gnc:pagename-display optname-show-budget))
+ (list 'show-difference
+ (get-option gnc:pagename-display optname-show-difference))
+ (list 'show-totalcol
+ (get-option gnc:pagename-display optname-show-totalcol))
+ (list 'rollup-budget
+ (get-option gnc:pagename-display optname-rollup-budget))
+ (list 'use-ranges use-ranges?)
+ (list 'collapse-before include-collapse-before?)
+ (list 'collapse-after include-collapse-after?)
+ (list 'user-start-period
+ (get-option gnc:pagename-general
+ optname-budget-period-start))
+ (list 'user-end-period
+ (get-option gnc:pagename-general
+ optname-budget-period-end))
+ (list 'user-start-period-exact
+ (to-period-val optname-budget-period-start-exact))
+ (list 'user-end-period-exact
+ (to-period-val optname-budget-period-end-exact))))
+ (report-name (get-option gnc:pagename-general
+ gnc:optname-reportname)))
+
+ (gnc:html-document-set-title!
+ doc (format #f (_ "~a: ~a")
+ report-name (gnc-budget-get-name budget)))
+
+ (set! accounts (sort accounts account-full-name<?))
+
+ (set! acct-table
+ (gnc:make-html-acct-table/env/accts env accounts))
+
+ ;; We do this in two steps: First the account names... the
+ ;; add-account-balances will actually compute and add a
+ ;; bunch of current account balances, too, but we'll
+ ;; overwrite them.
+ (set! html-table (gnc:html-table-add-account-balances
+ #f acct-table params))
+
+ ;; ... then the budget values
+ (gnc:html-table-add-budget-values!
+ html-table acct-table budget paramsBudget)
+
+ ;; hmmm... I expected that add-budget-values would have to
+ ;; clear out any unused columns to the right, out to the
+ ;; table width, since the add-account-balance had put stuff
+ ;; there, but it doesn't seem to matter.
+
+ (gnc:html-document-add-object! doc html-table)))))
(gnc:report-finished)
doc))
Summary of changes:
gnucash/report/standard-reports/budget.scm | 1068 ++++++++++++----------------
1 file changed, 450 insertions(+), 618 deletions(-)
More information about the gnucash-changes
mailing list