From 621c857b6a3df6a75b390f9cad6838dd80ea5db4 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Mon, 30 Sep 2019 23:36:59 +0800 Subject: [PATCH 01/13] [income-statement] remove dead code, compact function column and balance were unused. compact function. --- .../standard-reports/income-statement.scm | 54 ++++++------------- 1 file changed, 17 insertions(+), 37 deletions(-) diff --git a/gnucash/report/standard-reports/income-statement.scm b/gnucash/report/standard-reports/income-statement.scm index d5477685df..2a9918c8d2 100644 --- a/gnucash/report/standard-reports/income-statement.scm +++ b/gnucash/report/standard-reports/income-statement.scm @@ -445,43 +445,23 @@ (trading-table #f) (period-for (string-append " " (_ "for Period")))) - - ;; a helper to add a line to our report - (define (report-line - table pos-label neg-label amount col - exchange-fn rule? row-style) - (let* ((neg? (and amount - neg-label - (gnc-numeric-negative-p - (gnc:gnc-monetary-amount - (gnc:sum-collector-commodity - amount report-commodity exchange-fn))))) - (label (if neg? (or neg-label pos-label) pos-label)) - (pos-bal (if neg? - (let ((bal (gnc:make-commodity-collector))) - (bal 'minusmerge amount #f) - bal) - amount)) - (bal (gnc:sum-collector-commodity - pos-bal report-commodity exchange-fn)) - (balance - (or (and (gnc:uniform-commodity? pos-bal report-commodity) - bal) - (and show-fcur? - (gnc-commodity-table - pos-bal report-commodity exchange-fn)) - bal - )) - (column (or col 0)) - ) - (gnc:html-table-add-labeled-amount-line! - table (* 2 tree-depth) row-style rule? - label 0 1 "text-cell" - bal (+ col 1) 1 "number-cell") - ) - ) - - ;; sum revenues and expenses + + ;; a helper to add a line to our report + (define (report-line + table pos-label neg-label amount col + exchange-fn rule? row-style) + (let* ((mon (gnc:sum-collector-commodity + amount report-commodity exchange-fn)) + (neg? (and amount neg-label + (negative? (gnc:gnc-monetary-amount mon)))) + (label (if neg? (or neg-label pos-label) pos-label)) + (bal (if neg? (gnc:monetary-neg mon) mon))) + (gnc:html-table-add-labeled-amount-line! + table (* 2 tree-depth) row-style rule? + label 0 1 "text-cell" + bal (+ col 1) 1 "number-cell"))) + + ;; sum revenues and expenses (set! revenue-closing (gnc:account-get-trans-type-balance-interval-with-closing revenue-accounts closing-pattern From bf202d14614aa8bc7bdde063851f345ceb15101f Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Mon, 30 Sep 2019 23:50:08 +0800 Subject: [PATCH 02/13] [income-statement] use collector arithmetic, define vars in formals --- .../standard-reports/income-statement.scm | 220 +++++++----------- 1 file changed, 86 insertions(+), 134 deletions(-) diff --git a/gnucash/report/standard-reports/income-statement.scm b/gnucash/report/standard-reports/income-statement.scm index 2a9918c8d2..4441013391 100644 --- a/gnucash/report/standard-reports/income-statement.scm +++ b/gnucash/report/standard-reports/income-statement.scm @@ -422,32 +422,71 @@ doc (gnc:html-make-no-account-warning reportname (gnc:report-id report-obj))) - - ;; Get all the balances for each of the account types. - (let* ((revenue-closing #f) - (expense-closing #f) - (neg-revenue-total #f) - (revenue-total #f) - (expense-total #f) - (trading-total #f) - (net-income #f) - - ;; Create the account tables below where their - ;; percentage time can be tracked. - (inc-table (gnc:make-html-table)) ;; gnc:html-table - (exp-table (gnc:make-html-table)) - (tra-table (gnc:make-html-table)) - (table-env #f) ;; parameters for :make- - (params #f) ;; and -add-account- - (revenue-table #f) ;; gnc:html-acct-table - (expense-table #f) ;; gnc:html-acct-table - (trading-table #f) + ;; Get all the balances for each of the account types. + (let* ((expense-total + (gnc:collector- + (gnc:accountlist-get-comm-balance-interval-with-closing + expense-accounts start-date end-date) + (gnc:account-get-trans-type-balance-interval-with-closing + expense-accounts closing-pattern start-date end-date))) + + (revenue-total + (gnc:collector- + (gnc:account-get-trans-type-balance-interval-with-closing + revenue-accounts closing-pattern start-date end-date) + (gnc:accountlist-get-comm-balance-interval-with-closing + revenue-accounts start-date end-date))) + + (trading-total + (gnc:accountlist-get-comm-balance-interval-with-closing + trading-accounts start-date end-date)) + + (net-income + (gnc:collector+ revenue-total + trading-total + (gnc:collector- expense-total))) + + (inc-table (gnc:make-html-table)) + (exp-table (gnc:make-html-table)) + (tra-table (gnc:make-html-table)) + + (table-env + (list + (list 'start-date start-date) + (list 'end-date end-date) + (list 'display-tree-depth tree-depth) + (list 'depth-limit-behavior (if bottom-behavior 'flatten 'summarize)) + (list 'report-commodity report-commodity) + (list 'exchange-fn exchange-fn) + (list 'parent-account-subtotal-mode parent-total-mode) + (list 'zero-balance-mode + (if show-zb-accts? 'show-leaf-acct 'omit-leaf-acct)) + (list 'account-label-mode (if use-links? 'anchor 'name)) + ;; we may, at some point, want to add an option to + ;; generate a pre-adjustment income statement... + (list 'balance-mode 'pre-closing) + (list 'closing-pattern closing-pattern))) + + (params + (list + (list 'parent-account-balance-mode parent-balance-mode) + (list 'zero-balance-display-mode + (if omit-zb-bals? 'omit-balance 'show-balance)) + (list 'multicommodity-mode (and show-fcur? 'table)) + (list 'rule-mode use-rules?))) + + (revenue-table + (gnc:make-html-acct-table/env/accts table-env revenue-accounts)) + (expense-table + (gnc:make-html-acct-table/env/accts table-env expense-accounts)) + (trading-table + (gnc:make-html-acct-table/env/accts table-env trading-accounts)) (period-for (string-append " " (_ "for Period")))) ;; a helper to add a line to our report - (define (report-line + (define (add-report-line table pos-label neg-label amount col exchange-fn rule? row-style) (let* ((mon (gnc:sum-collector-commodity @@ -461,123 +500,36 @@ label 0 1 "text-cell" bal (+ col 1) 1 "number-cell"))) - ;; sum revenues and expenses - (set! revenue-closing - (gnc:account-get-trans-type-balance-interval-with-closing - revenue-accounts closing-pattern - start-date end-date) - ) ;; this is norm positive (debit) - (set! expense-closing - (gnc:account-get-trans-type-balance-interval-with-closing - expense-accounts closing-pattern - start-date end-date) - ) ;; this is norm negative (credit) - (set! expense-total - (gnc:accountlist-get-comm-balance-interval-with-closing - expense-accounts - start-date end-date)) - (expense-total 'minusmerge expense-closing #f) - (set! neg-revenue-total - (gnc:accountlist-get-comm-balance-interval-with-closing - revenue-accounts - start-date end-date)) - (neg-revenue-total 'minusmerge revenue-closing #f) - (set! revenue-total (gnc:make-commodity-collector)) - (revenue-total 'minusmerge neg-revenue-total #f) - (set! trading-total - (gnc:accountlist-get-comm-balance-interval-with-closing - trading-accounts - start-date end-date)) - ;; calculate net income - (set! net-income (gnc:make-commodity-collector)) - (net-income 'merge revenue-total #f) - (net-income 'merge trading-total #f) - (net-income 'minusmerge expense-total #f) - - (set! table-env - (list - (list 'start-date start-date) - (list 'end-date end-date) - (list 'display-tree-depth tree-depth) - (list 'depth-limit-behavior (if bottom-behavior - 'flatten - 'summarize)) - (list 'report-commodity report-commodity) - (list 'exchange-fn exchange-fn) - (list 'parent-account-subtotal-mode parent-total-mode) - (list 'zero-balance-mode (if show-zb-accts? - 'show-leaf-acct - 'omit-leaf-acct)) - (list 'account-label-mode (if use-links? - 'anchor - 'name)) - ;; we may, at some point, want to add an option to - ;; generate a pre-adjustment income statement... - (list 'balance-mode 'pre-closing) - (list 'closing-pattern closing-pattern) - ) - ) - (set! params - (list - (list 'parent-account-balance-mode parent-balance-mode) - (list 'zero-balance-display-mode (if omit-zb-bals? - 'omit-balance - 'show-balance)) - (list 'multicommodity-mode (if show-fcur? 'table #f)) - (list 'rule-mode use-rules?) - ) - ) - - (let ((space (make-list tree-depth (gnc:make-html-table-cell/min-width 60)))) + (let ((space (make-list tree-depth (gnc:make-html-table-cell/min-width 60)))) (gnc:html-table-append-row! inc-table space) (gnc:html-table-append-row! exp-table space) (gnc:html-table-append-row! tra-table space)) + (gnc:report-percent-done 80) - (gnc:report-percent-done 80) - (if label-revenue? - (add-subtotal-line inc-table (_ "Revenues") #f #f)) - (set! revenue-table - (gnc:make-html-acct-table/env/accts - table-env revenue-accounts)) - (gnc:html-table-add-account-balances - inc-table revenue-table params) - (if total-revenue? - (add-subtotal-line - inc-table (_ "Total Revenue") #f revenue-total)) - - (gnc:report-percent-done 85) - (if label-expense? - (add-subtotal-line - exp-table (_ "Expenses") #f #f)) - (set! expense-table - (gnc:make-html-acct-table/env/accts - table-env expense-accounts)) - (gnc:html-table-add-account-balances - exp-table expense-table params) - (if total-expense? - (add-subtotal-line - exp-table (_ "Total Expenses") #f expense-total)) - - (if label-trading? - (add-subtotal-line tra-table (_ "Trading") #f #f)) - (set! trading-table - (gnc:make-html-acct-table/env/accts - table-env trading-accounts)) - (gnc:html-table-add-account-balances - tra-table trading-table params) - (if total-trading? - (add-subtotal-line - tra-table (_ "Total Trading") #f trading-total)) - - (report-line - (if standard-order? - exp-table - inc-table) - (string-append (_ "Net income") period-for) - (string-append (_ "Net loss") period-for) - net-income - (* 2 (- tree-depth 1)) exchange-fn #f #f - ) + (when label-revenue? + (add-subtotal-line inc-table (_ "Revenues") #f #f)) + (gnc:html-table-add-account-balances inc-table revenue-table params) + (when total-revenue? + (add-subtotal-line inc-table (_ "Total Revenue") #f revenue-total)) + (gnc:report-percent-done 85) + + (when label-expense? + (add-subtotal-line exp-table (_ "Expenses") #f #f)) + (gnc:html-table-add-account-balances exp-table expense-table params) + (when total-expense? + (add-subtotal-line exp-table (_ "Total Expenses") #f expense-total)) + + (when label-trading? + (add-subtotal-line tra-table (_ "Trading") #f #f)) + (gnc:html-table-add-account-balances tra-table trading-table params) + (when total-trading? + (add-subtotal-line tra-table (_ "Total Trading") #f trading-total)) + + (add-report-line + (if standard-order? exp-table inc-table) + (string-append (_ "Net income") period-for) + (string-append (_ "Net loss") period-for) + net-income (* 2 (1- tree-depth)) exchange-fn #f #f) (gnc:html-document-add-object! doc From 34bb47e23f9beacf1d219b4fd7a7868d9d131ad4 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Tue, 1 Oct 2019 00:06:48 +0800 Subject: [PATCH 03/13] [income-statement] compact functions --- .../standard-reports/income-statement.scm | 169 +++++++----------- 1 file changed, 65 insertions(+), 104 deletions(-) diff --git a/gnucash/report/standard-reports/income-statement.scm b/gnucash/report/standard-reports/income-statement.scm index 4441013391..55d45f73af 100644 --- a/gnucash/report/standard-reports/income-statement.scm +++ b/gnucash/report/standard-reports/income-statement.scm @@ -383,45 +383,40 @@ (exchange-fn (gnc:case-exchange-fn price-source report-commodity end-date)) ) - + ;; Wrapper to call gnc:html-table-add-labeled-amount-line! ;; with the proper arguments. (define (add-subtotal-line table pos-label neg-label signed-balance) - (let* ((neg? (and signed-balance - neg-label - (gnc-numeric-negative-p - (gnc:gnc-monetary-amount - (gnc:sum-collector-commodity - signed-balance report-commodity exchange-fn))))) - (label (if neg? (or neg-label pos-label) pos-label)) - (balance (if neg? (gnc:collector- signed-balance) signed-balance))) - (gnc:html-table-add-labeled-amount-line! - table (* tree-depth 2) "primary-subheading" #f label 0 1 "total-label-cell" - (gnc:sum-collector-commodity balance report-commodity exchange-fn) - (1- (* tree-depth 2)) 1 "total-number-cell"))) - + (let* ((neg? (and signed-balance neg-label + (negative? + (gnc:gnc-monetary-amount + (gnc:sum-collector-commodity + signed-balance report-commodity exchange-fn))))) + (label (if neg? (or neg-label pos-label) pos-label)) + (balance (if neg? (gnc:collector- signed-balance) signed-balance))) + (gnc:html-table-add-labeled-amount-line! + table (* tree-depth 2) "primary-subheading" #f label 0 1 "total-label-cell" + (gnc:sum-collector-commodity balance report-commodity exchange-fn) + (1- (* tree-depth 2)) 1 "total-number-cell"))) + ;; wrapper around gnc:html-table-append-ruler! (define (add-rule table) (gnc:html-table-append-ruler! table (* 2 tree-depth))) - - (gnc:html-document-set-title! - doc (format #f - (string-append "~a ~a " - (_ "For Period Covering ~a to ~a")) - company-name report-title + + (gnc:html-document-set-title! + doc (format #f (string-append "~a ~a " (_ "For Period Covering ~a to ~a")) + company-name report-title (qof-print-date start-date-printable) (qof-print-date end-date))) - + (if (null? accounts) - - ;; error condition: no accounts specified - ;; is this *really* necessary?? - ;; i'd be fine with an all-zero P&L - ;; that would, technically, be correct.... - (gnc:html-document-add-object! - doc - (gnc:html-make-no-account-warning - reportname (gnc:report-id report-obj))) + + ;; error condition: no accounts specified is this *really* + ;; necessary?? i'd be fine with an all-zero P&L that would, + ;; technically, be correct.... + (gnc:html-document-add-object! + doc (gnc:html-make-no-account-warning + reportname (gnc:report-id report-obj))) ;; Get all the balances for each of the account types. (let* ((expense-total @@ -530,82 +525,48 @@ (string-append (_ "Net income") period-for) (string-append (_ "Net loss") period-for) net-income (* 2 (1- tree-depth)) exchange-fn #f #f) - - (gnc:html-document-add-object! - doc - (let* ((build-table (gnc:make-html-table))) - (if two-column? - (gnc:html-table-append-row! - build-table - (if standard-order? - (list - (gnc:make-html-table-cell inc-table) - (if (null? trading-accounts) - (gnc:html-make-empty-cell) - (gnc:make-html-table-cell tra-table)) - (gnc:make-html-table-cell exp-table) - ) - (list - (gnc:make-html-table-cell exp-table) - (gnc:make-html-table-cell inc-table) - (if (null? trading-accounts) - (gnc:html-make-empty-cell) - (gnc:make-html-table-cell tra-table)) - ) - ) - ) - (if standard-order? - (begin - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell inc-table))) - (if (not (null? trading-accounts)) - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell tra-table)))) - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell exp-table))) - ) - (begin - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell exp-table))) - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell inc-table))) - (if (not (null? trading-accounts)) - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell tra-table)))) - ) - ) - ) - - (gnc:html-table-set-style! - build-table "td" - 'attribute '("align" "left") - 'attribute '("valign" "top")) - build-table - ) - ) - - - + + ;; add the sections in the desired order to document + (let ((build-table (gnc:make-html-table)) + (inc-cell (gnc:make-html-table-cell inc-table)) + (tra-cell (if (null? trading-accounts) + (gnc:html-make-empty-cell) + (gnc:make-html-table-cell tra-table))) + (exp-cell (gnc:make-html-table-cell exp-table))) + (define (add-cells . lst) (gnc:html-table-append-row! build-table lst)) + (cond + ((and two-column? standard-order?) + (add-cells inc-cell tra-cell exp-cell)) + + (two-column? + (add-cells exp-cell inc-cell tra-cell)) + + (standard-order? + (add-cells inc-cell) + (unless (null? trading-accounts) (add-cells tra-cell)) + (add-cells exp-cell)) + + (else + (add-cells exp-cell) + (add-cells inc-cell) + (unless (null? trading-accounts) (add-cells tra-cell)))) + + (gnc:html-table-set-style! + build-table "td" + 'attribute '("align" "left") + 'attribute '("valign" "top")) + (gnc:html-document-add-object! doc build-table)) + ;; add currency information if requested - (gnc:report-percent-done 90) - (if show-rates? - (gnc:html-document-add-object! - doc ;;(gnc:html-markup-p) - (gnc:html-make-exchangerates - report-commodity exchange-fn accounts))) - (gnc:report-percent-done 100) - - ) - ) - + (gnc:report-percent-done 90) + (when show-rates? + (gnc:html-document-add-object! + doc (gnc:html-make-exchangerates + report-commodity exchange-fn accounts))) + (gnc:report-percent-done 100))) + (gnc:report-finished) - + doc)) (define is-reportname (N_ "Income Statement")) From 8f1c82e875d5d8152d0d96a228035fde5e1bb895 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Tue, 1 Oct 2019 01:21:20 +0800 Subject: [PATCH 04/13] [cash-flow] use collector arithmetic --- gnucash/report/standard-reports/cash-flow.scm | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/gnucash/report/standard-reports/cash-flow.scm b/gnucash/report/standard-reports/cash-flow.scm index 9a35699d2a..67e9a47529 100644 --- a/gnucash/report/standard-reports/cash-flow.scm +++ b/gnucash/report/standard-reports/cash-flow.scm @@ -196,8 +196,6 @@ (let* ((tree-depth (if (equal? display-depth 'all) (accounts-get-children-depth accounts) display-depth)) - - (money-diff-collector (gnc:make-commodity-collector)) (account-disp-list (map (lambda (account) @@ -253,8 +251,6 @@ account-full-name Date: Wed, 2 Oct 2019 21:49:41 +0800 Subject: [PATCH 05/13] [test-budget] augment to test budget-income-statement.scm --- .../standard-reports/test/test-budget.scm | 53 +++++++++++++++---- 1 file changed, 43 insertions(+), 10 deletions(-) diff --git a/gnucash/report/standard-reports/test/test-budget.scm b/gnucash/report/standard-reports/test/test-budget.scm index c471ca7bf7..0c59686cf3 100644 --- a/gnucash/report/standard-reports/test/test-budget.scm +++ b/gnucash/report/standard-reports/test/test-budget.scm @@ -31,18 +31,26 @@ (use-modules (gnucash engine)) (use-modules (sw_engine)) (use-modules (gnucash report standard-reports budget)) +(use-modules (gnucash report standard-reports budget-income-statement)) (use-modules (gnucash report report-system test test-extras)) (use-modules (gnucash report stylesheets)) (use-modules (gnucash engine test test-extras)) +(use-modules (sxml xpath)) ;; Explicitly set locale to make the report output predictable (setlocale LC_ALL "C") -(define uuid "810ed4b25ef0486ea43bbd3dddb32b11") +(define budget-uuid "810ed4b25ef0486ea43bbd3dddb32b11") +(define budget-is-uuid "583c313fcc484efc974c4c844404f454") (define (run-test) (test-runner-factory gnc:test-runner) (test-begin "budget") - (test-budget) + (test-group-with-cleanup "budget.scm" + (test-budget) + (teardown)) + (test-group-with-cleanup "budget-income-statement.scm" + (test-budget-income-statement) + (teardown)) (test-end "budget")) (define (set-option options page tag value) @@ -51,7 +59,7 @@ (define (teardown) (gnc-clear-current-session)) -(define (options->sxml options test-title) +(define (options->sxml options uuid test-title) (gnc:options->sxml uuid options "test-budget" test-title)) (define (create-budget-and-transactions env account-alist) @@ -88,15 +96,16 @@ (let* ((env (create-test-env)) (account-alist (create-test-data)) (budget (create-budget-and-transactions env account-alist)) - (options (gnc:make-report-options uuid)) + (options (gnc:make-report-options budget-uuid)) (bank (cdr (assoc "Bank" account-alist)))) + (display "\nbudget.scm\n") (set-option options "Accounts" "Account Display Depth" 'all) (set-option options "Display" "Show Difference" #f) (set-option options "Display" "Show Budget" #f) (set-option options "Display" "Show Actual" #f) - (let ((sxml (options->sxml options "basic all display off"))) + (let ((sxml (options->sxml options budget-uuid "basic all display off"))) (test-equal "all display OFF, table has 15 cells" 15 (length (sxml->table-row-col sxml 1 #f #f)))) @@ -105,7 +114,7 @@ (set-option options "Display" "Show Budget" #t) (set-option options "Display" "Show Actual" #t) (set-option options "Display" "Show Column with Totals" #t) - (let ((sxml (options->sxml options "basic"))) + (let ((sxml (options->sxml options budget-uuid "basic"))) (test-equal "all display ON, table has 226 cells" 226 (length (sxml->table-row-col sxml 1 #f #f))) @@ -128,7 +137,7 @@ (set-option options "General" "Report for range of budget periods" #t) (set-option options "General" "Range start" 'current) (set-option options "General" "Range end" 'next) - (let ((sxml (options->sxml options "only next period"))) + (let ((sxml (options->sxml options budget-uuid "only next period"))) (test-equal "only next period - 133 cells" 133 (length (sxml->table-row-col sxml 1 #f #f))) @@ -140,7 +149,7 @@ (set-option options "General" "Range start" 'last) (set-option options "General" "Range end" 'last) - (let ((sxml (options->sxml options "only last period"))) + (let ((sxml (options->sxml options budget-uuid "only last period"))) (test-equal "only last period - 102 cells" 102 (length (sxml->table-row-col sxml 1 #f #f))) @@ -156,7 +165,7 @@ (set-option options "General" "Exact end period" 4) (set-option options "General" "Include collapsed periods before selected." #f) (set-option options "General" "Include collapsed periods after selected." #f) - (let ((sxml (options->sxml options "exact periods"))) + (let ((sxml (options->sxml options budget-uuid "exact periods"))) (test-equal "exact periods - 133 cells" 133 (length (sxml->table-row-col sxml 1 #f #f))) @@ -167,9 +176,33 @@ (sxml->table-row-col sxml 1 5 #f))) (set-option options "General" "Use accumulated amounts" #t) - (let ((sxml (options->sxml options "Use accumulated amounts"))) + (let ((sxml (options->sxml options budget-uuid "Use accumulated amounts"))) (test-equal "use accumulated amounts" '("Bank" "$60.00" "$15.00" "$45.00" "$60.00" "$82.00" "-$22.00" "$120.00" "$159.00" "-$39.00" "$120.00" "$159.00" "-$39.00") (sxml->table-row-col sxml 1 5 #f))) )) + +(define (test-budget-income-statement) + (let* ((env (create-test-env)) + (account-alist (create-test-data)) + (budget (create-budget-and-transactions env account-alist)) + (options (gnc:make-report-options budget-is-uuid)) + (bank (assoc-ref account-alist "Bank"))) + + (display "\nbudget-income-statement.scm\n") + (let ((sxml (options->sxml options budget-is-uuid "budget-is-basic"))) + (test-equal "basic test" + 72 + (length (sxml->table-row-col sxml 1 #f #f))) + + (test-equal "budgeted income amounts" + '("$195.00" "Income") + ((sxpath '(// table // (tr 1) // table // (tr 3) // *text*)) + sxml)) + + (test-equal "net loss for budget" + '("Net loss for Budget test budget" "$285.00") + ((sxpath '(// table // (tr 2) // table // (tr 5) // *text*)) + sxml))))) + From 1dfd7c5547cd7f0842f0a2e5cd8952e84b17f420 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Tue, 1 Oct 2019 00:48:16 +0800 Subject: [PATCH 06/13] [budget-income-statement] compact functions neater. --- .../budget-income-statement.scm | 452 ++++++++---------- 1 file changed, 209 insertions(+), 243 deletions(-) diff --git a/gnucash/report/standard-reports/budget-income-statement.scm b/gnucash/report/standard-reports/budget-income-statement.scm index d26085212d..29baf0751c 100644 --- a/gnucash/report/standard-reports/budget-income-statement.scm +++ b/gnucash/report/standard-reports/budget-income-statement.scm @@ -417,270 +417,236 @@ ;; wrapper around gnc:html-table-append-ruler! (define (add-rule table) - (gnc:html-table-append-ruler! - table (* 2 tree-depth))) - + (gnc:html-table-append-ruler! table (* 2 tree-depth))) + (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 report-title))) - ((and use-budget-period-range? - (< user-budget-period-end user-budget-period-start)) - ;; User has selected a range with end period lower than start period. - (gnc:html-document-add-object! - doc - (gnc:html-make-generic-simple-warning + ((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 report-title))) + + ((and use-budget-period-range? + (< user-budget-period-end user-budget-period-start)) + ;; User has selected a range with end period lower than start period. + (gnc:html-document-add-object! + doc (gnc:html-make-generic-simple-warning report-title (_ "Reporting range end period cannot be less than start period.")))) - (else (begin - ;; Get all the balances for each of the account types. - (let* ( - (revenue-account-balances #f) - (expense-account-balances #f) - (revenue-total #f) - (revenue-get-balance-fn #f) + (else + ;; Get all the balances for each of the account types. + (let* ( + (revenue-account-balances #f) + (expense-account-balances #f) - (expense-total #f) - (expense-get-balance-fn #f) + (revenue-total #f) + (revenue-get-balance-fn #f) - (net-income #f) - - ;; Create the account tables below where their - ;; percentage time can be tracked. - (inc-table (gnc:make-html-table)) ;; gnc:html-table - (exp-table (gnc:make-html-table)) + (expense-total #f) + (expense-get-balance-fn #f) - (table-env #f) ;; parameters for :make- - (params #f) ;; and -add-account- - (revenue-table #f) ;; gnc:html-acct-table - (expense-table #f) ;; gnc:html-acct-table - (budget-name (gnc-budget-get-name budget)) - (period-for - (if use-budget-period-range? - (if (equal? user-budget-period-start user-budget-period-end) - (format - #f - (_ "for Budget ~a Period ~d") - budget-name - user-budget-period-start) - (format - #f - (_ "for Budget ~a Periods ~d - ~d") - budget-name - user-budget-period-start - user-budget-period-end)) - (format - #f - (_ "for Budget ~a") - budget-name))) - ) + (net-income #f) - ;; a helper to add a line to our report - (define (report-line - table pos-label neg-label amount col exchange-fn rule? row-style) - (let* ((neg? (and amount neg-label - (negative? - (gnc:gnc-monetary-amount - (gnc:sum-collector-commodity - amount report-commodity exchange-fn))))) - (label (if neg? (or neg-label pos-label) pos-label)) - (abs-amt (if neg? (gnc:collector- amount) amount)) - (bal (gnc:sum-collector-commodity - abs-amt report-commodity exchange-fn))) - (gnc:html-table-add-labeled-amount-line! - table (* 2 tree-depth) row-style rule? - label 0 1 "text-cell" - bal (1+ col) 1 "number-cell"))) + ;; Create the account tables below where their + ;; percentage time can be tracked. + (inc-table (gnc:make-html-table)) ;; gnc:html-table + (exp-table (gnc:make-html-table)) - (gnc:report-percent-done 5) + (table-env #f) ;; parameters for :make- + (params #f) ;; and -add-account- + (revenue-table #f) ;; gnc:html-acct-table + (expense-table #f) ;; gnc:html-acct-table + (budget-name (gnc-budget-get-name budget)) + (period-for + (cond + ((not use-budget-period-range?) + (format #f (_ "for Budget ~a") budget-name)) + ((= user-budget-period-start user-budget-period-end) + (format #f (_ "for Budget ~a Period ~d") + budget-name user-budget-period-start)) + (else + (format #f (_ "for Budget ~a Periods ~d - ~d") + budget-name user-budget-period-start + user-budget-period-end))))) - ;; Pre-fetch expense account balances. - (set! expense-account-balances - (get-assoc-account-balances-budget - budget - expense-accounts - period-start - period-end - get-budget-account-budget-balance)) + ;; a helper to add a line to our report + (define (report-line + table pos-label neg-label amount col exchange-fn rule? row-style) + (let* ((neg? (and amount neg-label + (negative? + (gnc:gnc-monetary-amount + (gnc:sum-collector-commodity + amount report-commodity exchange-fn))))) + (label (if neg? (or neg-label pos-label) pos-label)) + (abs-amt (if neg? (gnc:collector- amount) amount)) + (bal (gnc:sum-collector-commodity + abs-amt report-commodity exchange-fn))) + (gnc:html-table-add-labeled-amount-line! + table (* 2 tree-depth) row-style rule? + label 0 1 "text-cell" + bal (1+ col) 1 "number-cell"))) - ;; Total expenses. - (set! expense-total - (gnc:get-assoc-account-balances-total expense-account-balances)) + (gnc:report-percent-done 5) - ;; Function to get individual expense account total. - (set! expense-get-balance-fn - (lambda (account start-date end-date) - (gnc:select-assoc-account-balance expense-account-balances account))) + ;; Pre-fetch expense account balances. + (set! expense-account-balances + (get-assoc-account-balances-budget + budget + expense-accounts + period-start + period-end + get-budget-account-budget-balance)) - (gnc:report-percent-done 10) + ;; Total expenses. + (set! expense-total + (gnc:get-assoc-account-balances-total expense-account-balances)) - ;; Pre-fetch revenue account balances. - (set! revenue-account-balances - (get-assoc-account-balances-budget - budget - revenue-accounts - period-start - period-end - get-budget-account-budget-balance)) + ;; Function to get individual expense account total. + (set! expense-get-balance-fn + (lambda (account start-date end-date) + (gnc:select-assoc-account-balance expense-account-balances account))) - ;; Total revenue. - (set! revenue-total - (gnc:get-assoc-account-balances-total revenue-account-balances)) + (gnc:report-percent-done 10) - ;; Function to get individual revenue account total. - ;; Budget revenue is always positive, so this must be negated. - (set! revenue-get-balance-fn - (lambda (account start-date end-date) - (gnc:commodity-collector-get-negated - (gnc:select-assoc-account-balance revenue-account-balances account)))) + ;; Pre-fetch revenue account balances. + (set! revenue-account-balances + (get-assoc-account-balances-budget + budget + revenue-accounts + period-start + period-end + get-budget-account-budget-balance)) - (gnc:report-percent-done 20) + ;; Total revenue. + (set! revenue-total + (gnc:get-assoc-account-balances-total revenue-account-balances)) - ;; calculate net income - (set! net-income - (gnc:collector- revenue-total expense-total)) + ;; Function to get individual revenue account total. + ;; Budget revenue is always positive, so this must be negated. + (set! revenue-get-balance-fn + (lambda (account start-date end-date) + (gnc:commodity-collector-get-negated + (gnc:select-assoc-account-balance revenue-account-balances account)))) - (gnc:report-percent-done 30) + (gnc:report-percent-done 20) - (gnc:html-document-set-title! - doc - (format #f "~a ~a ~a" company-name report-title period-for)) + ;; calculate net income + (set! net-income + (gnc:collector- revenue-total expense-total)) - (set! table-env - (list - (list 'display-tree-depth tree-depth) - (list 'depth-limit-behavior (if bottom-behavior - 'flatten - 'summarize)) - (list 'report-commodity report-commodity) - (list 'exchange-fn exchange-fn) - (list 'parent-account-subtotal-mode parent-total-mode) - (list 'zero-balance-mode (if show-zb-accts? - 'show-leaf-acct - 'omit-leaf-acct)) - (list 'account-label-mode (if use-links? - 'anchor - 'name)) - ) - ) - (set! params - (list - (list 'parent-account-balance-mode parent-balance-mode) - (list 'zero-balance-display-mode (if omit-zb-bals? - 'omit-balance - 'show-balance)) - (list 'multicommodity-mode (if show-fcur? 'table #f)) - (list 'rule-mode use-rules?) - ) - ) - - (let ((space (make-list tree-depth (gnc:make-html-table-cell/min-width 60)))) - (gnc:html-table-append-row! inc-table space) - (gnc:html-table-append-row! exp-table space)) - - (gnc:report-percent-done 80) - (if label-revenue? - (add-subtotal-line inc-table (_ "Revenues") #f #f)) - (set! revenue-table - (gnc:make-html-acct-table/env/accts - (append table-env (list (list 'get-balance-fn revenue-get-balance-fn))) - revenue-accounts)) - (gnc:html-table-add-account-balances - inc-table revenue-table params) - (if total-revenue? - (add-subtotal-line - inc-table (_ "Total Revenue") #f revenue-total)) - - (gnc:report-percent-done 85) - (if label-expense? - (add-subtotal-line - exp-table (_ "Expenses") #f #f)) - (set! expense-table - (gnc:make-html-acct-table/env/accts - (append table-env (list (list 'get-balance-fn expense-get-balance-fn))) - expense-accounts)) - (gnc:html-table-add-account-balances - exp-table expense-table params) - (if total-expense? - (add-subtotal-line - exp-table (_ "Total Expenses") #f expense-total)) - - (report-line - (if standard-order? - exp-table - inc-table) - (string-append (_ "Net income") " " period-for) - (string-append (_ "Net loss") " " period-for) - net-income - (* 2 (- tree-depth 1)) exchange-fn #f #f - ) - - (gnc:html-document-add-object! - doc - (let* ((build-table (gnc:make-html-table))) - (if two-column? - (gnc:html-table-append-row! - build-table - (if standard-order? - (list - (gnc:make-html-table-cell inc-table) - (gnc:make-html-table-cell exp-table) - ) - (list - (gnc:make-html-table-cell exp-table) - (gnc:make-html-table-cell inc-table) - ) - ) - ) - (if standard-order? - (begin - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell inc-table))) - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell exp-table))) - ) - (begin - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell exp-table))) - (gnc:html-table-append-row! - build-table - (list (gnc:make-html-table-cell inc-table))) - ) - ) - ) - - (gnc:html-table-set-style! - build-table "td" - 'attribute '("align" "left") - 'attribute '("valign" "top")) - build-table - ) - ) - - - - ;; add currency information if requested - (gnc:report-percent-done 90) - (if show-rates? - (gnc:html-document-add-object! - doc ;;(gnc:html-markup-p) - (gnc:html-make-exchangerates - report-commodity exchange-fn accounts))) - (gnc:report-percent-done 100) - - ) - ))) ;; end cond + (gnc:report-percent-done 30) + + (gnc:html-document-set-title! + doc + (format #f "~a ~a ~a" company-name report-title period-for)) + + (set! table-env + (list + (list 'display-tree-depth tree-depth) + (list 'depth-limit-behavior (if bottom-behavior + 'flatten + 'summarize)) + (list 'report-commodity report-commodity) + (list 'exchange-fn exchange-fn) + (list 'parent-account-subtotal-mode parent-total-mode) + (list 'zero-balance-mode (if show-zb-accts? + 'show-leaf-acct + 'omit-leaf-acct)) + (list 'account-label-mode (if use-links? + 'anchor + 'name)) + ) + ) + (set! params + (list + (list 'parent-account-balance-mode parent-balance-mode) + (list 'zero-balance-display-mode (if omit-zb-bals? + 'omit-balance + 'show-balance)) + (list 'multicommodity-mode (if show-fcur? 'table #f)) + (list 'rule-mode use-rules?) + ) + ) + + (let ((space (make-list tree-depth (gnc:make-html-table-cell/min-width 60)))) + (gnc:html-table-append-row! inc-table space) + (gnc:html-table-append-row! exp-table space)) + + (gnc:report-percent-done 80) + (if label-revenue? + (add-subtotal-line inc-table (_ "Revenues") #f #f)) + (set! revenue-table + (gnc:make-html-acct-table/env/accts + (append table-env (list (list 'get-balance-fn revenue-get-balance-fn))) + revenue-accounts)) + (gnc:html-table-add-account-balances + inc-table revenue-table params) + (if total-revenue? + (add-subtotal-line + inc-table (_ "Total Revenue") #f revenue-total)) + + (gnc:report-percent-done 85) + (if label-expense? + (add-subtotal-line + exp-table (_ "Expenses") #f #f)) + (set! expense-table + (gnc:make-html-acct-table/env/accts + (append table-env (list (list 'get-balance-fn expense-get-balance-fn))) + expense-accounts)) + (gnc:html-table-add-account-balances + exp-table expense-table params) + (if total-expense? + (add-subtotal-line + exp-table (_ "Total Expenses") #f expense-total)) + + (report-line + (if standard-order? + exp-table + inc-table) + (string-append (_ "Net income") " " period-for) + (string-append (_ "Net loss") " " period-for) + net-income + (* 2 (- tree-depth 1)) exchange-fn #f #f + ) + + (let ((build-table (gnc:make-html-table)) + (inc-cell (gnc:make-html-table-cell inc-table)) + (exp-cell (gnc:make-html-table-cell exp-table))) + (define (add-cells . lst) (gnc:html-table-append-row! build-table lst)) + (cond + ((and two-column? standard-order?) + (add-cells inc-cell exp-cell)) + + (two-column? + (add-cells exp-cell inc-cell)) + + (standard-order? + (add-cells inc-cell) + (add-cells exp-cell)) + + (else + (add-cells exp-cell) + (add-cells inc-cell))) + + (gnc:html-table-set-style! + build-table "td" + 'attribute '("align" "left") + 'attribute '("valign" "top")) + (gnc:html-document-add-object! doc build-table)) + + ;; add currency information if requested + (gnc:report-percent-done 90) + (when show-rates? + (gnc:html-document-add-object! + doc (gnc:html-make-exchangerates report-commodity exchange-fn accounts))) + (gnc:report-percent-done 100)))) (gnc:report-finished) From 3452c33cdf0b8d405ae50a6755346b45704a890d Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Tue, 1 Oct 2019 00:56:44 +0800 Subject: [PATCH 07/13] [budget-income-statement] define vars in formals and use collector arithmetic --- .../budget-income-statement.scm | 209 +++++++----------- 1 file changed, 79 insertions(+), 130 deletions(-) diff --git a/gnucash/report/standard-reports/budget-income-statement.scm b/gnucash/report/standard-reports/budget-income-statement.scm index 29baf0751c..a2393037c6 100644 --- a/gnucash/report/standard-reports/budget-income-statement.scm +++ b/gnucash/report/standard-reports/budget-income-statement.scm @@ -442,28 +442,88 @@ (else ;; Get all the balances for each of the account types. - (let* ( - (revenue-account-balances #f) - (expense-account-balances #f) + (let* ((revenue-account-balances + (get-assoc-account-balances-budget + budget revenue-accounts period-start period-end + get-budget-account-budget-balance)) - (revenue-total #f) - (revenue-get-balance-fn #f) + (expense-account-balances + (get-assoc-account-balances-budget + budget expense-accounts period-start period-end + get-budget-account-budget-balance)) - (expense-total #f) - (expense-get-balance-fn #f) + (revenue-total + (gnc:get-assoc-account-balances-total revenue-account-balances)) - (net-income #f) + (expense-total + (gnc:get-assoc-account-balances-total expense-account-balances)) - ;; Create the account tables below where their - ;; percentage time can be tracked. - (inc-table (gnc:make-html-table)) ;; gnc:html-table - (exp-table (gnc:make-html-table)) + (net-income + (gnc:collector- revenue-total expense-total)) + + (table-env + (list + (list 'display-tree-depth tree-depth) + (list 'depth-limit-behavior + (if bottom-behavior 'flatten 'summarize)) + (list 'report-commodity report-commodity) + (list 'exchange-fn exchange-fn) + (list 'parent-account-subtotal-mode parent-total-mode) + (list 'zero-balance-mode + (if show-zb-accts? 'show-leaf-acct 'omit-leaf-acct)) + (list 'account-label-mode (if use-links? 'anchor 'name)))) + + (params + (list + (list 'parent-account-balance-mode parent-balance-mode) + (list 'zero-balance-display-mode + (if omit-zb-bals? 'omit-balance 'show-balance)) + (list 'multicommodity-mode (and show-fcur? 'table)) + (list 'rule-mode use-rules?))) + + (revenue-get-balance-fn + (lambda (acct start-date end-date) + (gnc:collector- + (gnc:select-assoc-account-balance revenue-account-balances acct)))) + + (revenue-table + (gnc:make-html-acct-table/env/accts + (cons (list 'get-balance-fn revenue-get-balance-fn) table-env) + revenue-accounts)) + + (expense-get-balance-fn + (lambda (acct start-date end-date) + (gnc:select-assoc-account-balance expense-account-balances acct))) + + (expense-table + (gnc:make-html-acct-table/env/accts + (cons (list 'get-balance-fn expense-get-balance-fn) table-env) + expense-accounts)) + + (space (make-list tree-depth (gnc:make-html-table-cell/min-width 60))) + + (inc-table + (let ((table (gnc:make-html-table))) + (gnc:html-table-append-row! table space) + (when label-revenue? + (add-subtotal-line table (_ "Revenues") #f #f)) + (gnc:html-table-add-account-balances table revenue-table params) + (when total-revenue? + (add-subtotal-line table (_ "Total Revenue") #f revenue-total)) + table)) + + (exp-table + (let ((table (gnc:make-html-table))) + (gnc:html-table-append-row! table space) + (when label-expense? + (add-subtotal-line table (_ "Expenses") #f #f)) + (gnc:html-table-add-account-balances table expense-table params) + (when total-expense? + (add-subtotal-line table (_ "Total Expenses") #f expense-total)) + table)) - (table-env #f) ;; parameters for :make- - (params #f) ;; and -add-account- - (revenue-table #f) ;; gnc:html-acct-table - (expense-table #f) ;; gnc:html-acct-table (budget-name (gnc-budget-get-name budget)) + (period-for (cond ((not use-budget-period-range?) @@ -493,128 +553,17 @@ label 0 1 "text-cell" bal (1+ col) 1 "number-cell"))) - (gnc:report-percent-done 5) - - ;; Pre-fetch expense account balances. - (set! expense-account-balances - (get-assoc-account-balances-budget - budget - expense-accounts - period-start - period-end - get-budget-account-budget-balance)) - - ;; Total expenses. - (set! expense-total - (gnc:get-assoc-account-balances-total expense-account-balances)) - - ;; Function to get individual expense account total. - (set! expense-get-balance-fn - (lambda (account start-date end-date) - (gnc:select-assoc-account-balance expense-account-balances account))) - - (gnc:report-percent-done 10) - - ;; Pre-fetch revenue account balances. - (set! revenue-account-balances - (get-assoc-account-balances-budget - budget - revenue-accounts - period-start - period-end - get-budget-account-budget-balance)) - - ;; Total revenue. - (set! revenue-total - (gnc:get-assoc-account-balances-total revenue-account-balances)) - - ;; Function to get individual revenue account total. - ;; Budget revenue is always positive, so this must be negated. - (set! revenue-get-balance-fn - (lambda (account start-date end-date) - (gnc:commodity-collector-get-negated - (gnc:select-assoc-account-balance revenue-account-balances account)))) - - (gnc:report-percent-done 20) - - ;; calculate net income - (set! net-income - (gnc:collector- revenue-total expense-total)) - (gnc:report-percent-done 30) (gnc:html-document-set-title! - doc - (format #f "~a ~a ~a" company-name report-title period-for)) - - (set! table-env - (list - (list 'display-tree-depth tree-depth) - (list 'depth-limit-behavior (if bottom-behavior - 'flatten - 'summarize)) - (list 'report-commodity report-commodity) - (list 'exchange-fn exchange-fn) - (list 'parent-account-subtotal-mode parent-total-mode) - (list 'zero-balance-mode (if show-zb-accts? - 'show-leaf-acct - 'omit-leaf-acct)) - (list 'account-label-mode (if use-links? - 'anchor - 'name)) - ) - ) - (set! params - (list - (list 'parent-account-balance-mode parent-balance-mode) - (list 'zero-balance-display-mode (if omit-zb-bals? - 'omit-balance - 'show-balance)) - (list 'multicommodity-mode (if show-fcur? 'table #f)) - (list 'rule-mode use-rules?) - ) - ) - - (let ((space (make-list tree-depth (gnc:make-html-table-cell/min-width 60)))) - (gnc:html-table-append-row! inc-table space) - (gnc:html-table-append-row! exp-table space)) - - (gnc:report-percent-done 80) - (if label-revenue? - (add-subtotal-line inc-table (_ "Revenues") #f #f)) - (set! revenue-table - (gnc:make-html-acct-table/env/accts - (append table-env (list (list 'get-balance-fn revenue-get-balance-fn))) - revenue-accounts)) - (gnc:html-table-add-account-balances - inc-table revenue-table params) - (if total-revenue? - (add-subtotal-line - inc-table (_ "Total Revenue") #f revenue-total)) - - (gnc:report-percent-done 85) - (if label-expense? - (add-subtotal-line - exp-table (_ "Expenses") #f #f)) - (set! expense-table - (gnc:make-html-acct-table/env/accts - (append table-env (list (list 'get-balance-fn expense-get-balance-fn))) - expense-accounts)) - (gnc:html-table-add-account-balances - exp-table expense-table params) - (if total-expense? - (add-subtotal-line - exp-table (_ "Total Expenses") #f expense-total)) + doc (format #f "~a ~a ~a" company-name report-title period-for)) (report-line - (if standard-order? - exp-table - inc-table) + (if standard-order? exp-table inc-table) (string-append (_ "Net income") " " period-for) (string-append (_ "Net loss") " " period-for) net-income - (* 2 (- tree-depth 1)) exchange-fn #f #f - ) + (* 2 (1- tree-depth)) exchange-fn #f #f) (let ((build-table (gnc:make-html-table)) (inc-cell (gnc:make-html-table-cell inc-table)) From 34c677d70d13c8b4b97806af02a6d8c79f92ccd1 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Thu, 3 Oct 2019 00:01:47 +0800 Subject: [PATCH 08/13] [budget-flow] fixcrash: exchange-fn needs to specify exchange date because some exchange-fn *do* require date eg. pricedb-nearest. use the period end-date for the exchange date. --- gnucash/report/standard-reports/budget-flow.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/gnucash/report/standard-reports/budget-flow.scm b/gnucash/report/standard-reports/budget-flow.scm index 81fda0c031..f20a8f39f2 100644 --- a/gnucash/report/standard-reports/budget-flow.scm +++ b/gnucash/report/standard-reports/budget-flow.scm @@ -276,7 +276,8 @@ ;; calculate the exchange rates (exchange-fn (gnc:case-exchange-fn - price-source report-currency #f)) + price-source report-currency + (gnc-budget-get-period-end-date budget period))) ;; The HTML document (doc (gnc:make-html-document))) From 5d15fd41fd8c73869698a388b7baa3b722e75966 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Thu, 3 Oct 2019 00:41:43 +0800 Subject: [PATCH 09/13] [budget] fixcrash: prevent crash if periods start > end It's silly to input start-period > end-period. Nevertheless handle it by swapping them instead of crashing. i.e. report budget periods from end to start. --- gnucash/report/standard-reports/budget.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm index 17274811d1..71104db108 100644 --- a/gnucash/report/standard-reports/budget.scm +++ b/gnucash/report/standard-reports/budget.scm @@ -537,7 +537,9 @@ (define (calc-periods budget user-start user-end collapse-before? collapse-after? show-total?) (define (range start end) - (iota (- end start) start)) + (if (< start end) + (iota (- end start) start) + (iota (- start end) end))) (let* ((num-periods (gnc-budget-get-num-periods budget)) (range-start (or user-start 0)) (range-end (if user-end (1+ user-end) num-periods)) From f015a96833825df852f3e20bb5ce0ebcb78a8de4 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Thu, 3 Oct 2019 00:52:17 +0800 Subject: [PATCH 10/13] [budget] fixcrash: fix crasher for some periods eg. the following combo would previously crash: - periods from next to current - use accumulated amounts --- gnucash/report/standard-reports/budget.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm index 71104db108..b5c1c6443e 100644 --- a/gnucash/report/standard-reports/budget.scm +++ b/gnucash/report/standard-reports/budget.scm @@ -332,7 +332,7 @@ (let* ((comm (xaccAccountGetCommodity acct)) (reverse-balance? (gnc-reverse-balance acct)) (allperiods (filter number? (gnc:list-flatten column-list))) - (total-periods (if accumulate? + (total-periods (if (and accumulate? (not (null? allperiods))) (iota (1+ (apply max allperiods))) allperiods)) (income-acct? (eqv? (xaccAccountGetType acct) ACCT-TYPE-INCOME))) From c6195d6e7aa8e4dd691657df00aaccc85f92388a Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Thu, 3 Oct 2019 08:05:52 +0800 Subject: [PATCH 11/13] [test-budget] centralize gnc:create-budget-and-transactions it will be reused by test-stress-options --- .../standard-reports/test/test-budget.scm | 34 ++----------------- libgnucash/engine/test/test-extras.scm | 30 ++++++++++++++++ 2 files changed, 32 insertions(+), 32 deletions(-) diff --git a/gnucash/report/standard-reports/test/test-budget.scm b/gnucash/report/standard-reports/test/test-budget.scm index 0c59686cf3..21e5063164 100644 --- a/gnucash/report/standard-reports/test/test-budget.scm +++ b/gnucash/report/standard-reports/test/test-budget.scm @@ -62,40 +62,10 @@ (define (options->sxml options uuid test-title) (gnc:options->sxml uuid options "test-budget" test-title)) -(define (create-budget-and-transactions env account-alist) - (let* ((book (gnc-get-current-book)) - (budget (gnc-budget-new book)) - (bank (cdr (assoc "Bank" account-alist))) - (income (cdr (assoc "Income" account-alist))) - (expense (cdr (assoc "Expenses" account-alist)))) - (gnc-budget-set-name budget "test budget") - (gnc-budget-begin-edit budget) - (gnc-budget-set-num-periods budget 6) - (gnc-budget-set-account-period-value budget bank 0 20) - (gnc-budget-set-account-period-value budget bank 1 40) - (gnc-budget-set-account-period-value budget bank 3 60) - (gnc-budget-set-account-period-value budget expense 1 30) - (gnc-budget-set-account-period-value budget expense 2 20) - (gnc-budget-set-account-period-value budget expense 3 40) - (gnc-budget-set-account-period-value budget income 0 -55) - (gnc-budget-set-account-period-value budget income 2 -65) - (gnc-budget-set-account-period-value budget income 3 -75) - (gnc-budget-commit-edit budget) - (let ((midperiod (lambda (period) - (floor (/ (+ (gnc-budget-get-period-start-date budget period) - (gnc-budget-get-period-end-date budget period)) - 2))))) - (env-create-transaction env (midperiod 0) bank income 55) - (env-create-transaction env (midperiod 2) bank income 67) - (env-create-transaction env (midperiod 3) bank income 77) - (env-create-transaction env (midperiod 0) expense bank 20) - (env-create-transaction env (midperiod 1) expense bank 20)) - budget)) - (define (test-budget) (let* ((env (create-test-env)) (account-alist (create-test-data)) - (budget (create-budget-and-transactions env account-alist)) + (budget (gnc:create-budget-and-transactions env account-alist)) (options (gnc:make-report-options budget-uuid)) (bank (cdr (assoc "Bank" account-alist)))) @@ -186,7 +156,7 @@ (define (test-budget-income-statement) (let* ((env (create-test-env)) (account-alist (create-test-data)) - (budget (create-budget-and-transactions env account-alist)) + (budget (gnc:create-budget-and-transactions env account-alist)) (options (gnc:make-report-options budget-is-uuid)) (bank (assoc-ref account-alist "Bank"))) diff --git a/libgnucash/engine/test/test-extras.scm b/libgnucash/engine/test/test-extras.scm index 3fbe5bd9fc..126f7e0ec6 100644 --- a/libgnucash/engine/test/test-extras.scm +++ b/libgnucash/engine/test/test-extras.scm @@ -834,6 +834,36 @@ (vector inv-1 inv-2 inv-3 inv-4 inv-5 inv-6 inv-7 inv-8))) +(define-public (gnc:create-budget-and-transactions env account-alist) + (let* ((book (gnc-get-current-book)) + (budget (gnc-budget-new book)) + (bank (cdr (assoc "Bank" account-alist))) + (income (cdr (assoc "Income" account-alist))) + (expense (cdr (assoc "Expenses" account-alist)))) + (gnc-budget-set-name budget "test budget") + (gnc-budget-begin-edit budget) + (gnc-budget-set-num-periods budget 6) + (gnc-budget-set-account-period-value budget bank 0 20) + (gnc-budget-set-account-period-value budget bank 1 40) + (gnc-budget-set-account-period-value budget bank 3 60) + (gnc-budget-set-account-period-value budget expense 1 30) + (gnc-budget-set-account-period-value budget expense 2 20) + (gnc-budget-set-account-period-value budget expense 3 40) + (gnc-budget-set-account-period-value budget income 0 -55) + (gnc-budget-set-account-period-value budget income 2 -65) + (gnc-budget-set-account-period-value budget income 3 -75) + (gnc-budget-commit-edit budget) + (let ((midperiod (lambda (period) + (floor (/ (+ (gnc-budget-get-period-start-date budget period) + (gnc-budget-get-period-end-date budget period)) + 2))))) + (env-create-transaction env (midperiod 0) bank income 55) + (env-create-transaction env (midperiod 2) bank income 67) + (env-create-transaction env (midperiod 3) bank income 77) + (env-create-transaction env (midperiod 0) expense bank 20) + (env-create-transaction env (midperiod 1) expense bank 20)) + budget)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; various stock transactions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From d47e49c230c2085008cdf87b71ebb98cb6ccb1cb Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Thu, 3 Oct 2019 08:06:16 +0800 Subject: [PATCH 12/13] [test-stress-options] add budget to test book the populated book has a budget. this enables more thorough testing of budget reports. --- .../report/standard-reports/test/test-stress-options.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/gnucash/report/standard-reports/test/test-stress-options.scm b/gnucash/report/standard-reports/test/test-stress-options.scm index 028441bd5b..26110ca76c 100644 --- a/gnucash/report/standard-reports/test/test-stress-options.scm +++ b/gnucash/report/standard-reports/test/test-stress-options.scm @@ -264,7 +264,9 @@ optionslist)) (define (tests) - (run-tests "with empty book") - (create-test-data) + ;; (run-tests "with empty book") + (let ((env (create-test-env)) + (account-alist (create-test-data))) + (gnc:create-budget-and-transactions env account-alist)) (create-test-invoice-data) (run-tests "on a populated book")) From 315bbb5d0539d7d911b867b2eac8406f8d3e4484 Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Thu, 3 Oct 2019 13:02:08 +0800 Subject: [PATCH 13/13] [test-stress-options] reinstate test empty book d47e49c23 had disabled testing empty book in error. --- gnucash/report/standard-reports/test/test-stress-options.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gnucash/report/standard-reports/test/test-stress-options.scm b/gnucash/report/standard-reports/test/test-stress-options.scm index 26110ca76c..0a4925ebf1 100644 --- a/gnucash/report/standard-reports/test/test-stress-options.scm +++ b/gnucash/report/standard-reports/test/test-stress-options.scm @@ -264,7 +264,7 @@ optionslist)) (define (tests) - ;; (run-tests "with empty book") + (run-tests "with empty book") (let ((env (create-test-env)) (account-alist (create-test-data))) (gnc:create-budget-and-transactions env account-alist))