mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
[TR] [bugfix] upgrade add-subtotal-row & grid for >1 commodities.
This aims to handle multiple commodities correctly. If a row contains subtotals with more than one commodity, the row is duplicated so that every commodity gets its own line in the grid. This is accompanied by an upgrade to the test suite. Sample output if prime-sortkey = accounts, sec-sortkey = monthly dates Jan-17 Feb-17 Mar-17 Total Food $22.00 $23.00 $35.00 $80.00 Books $8.50 $9.55 $15.00 $33.05 Apps £2.55 £5.00 £9.60 £17.15 Total $113.05 £17.15 (note monthly totals are not displayed because they're not actually generated with the above sorting options)
This commit is contained in:
parent
98964f7a6d
commit
aafd46a442
@ -115,6 +115,7 @@
|
||||
(list "USD Bank")
|
||||
(list "Wallet"))
|
||||
(list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
|
||||
(list "Income-GBP" (list (cons 'type ACCT-TYPE-INCOME)))
|
||||
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE)))
|
||||
(list "Liabilities" (list (cons 'type ACCT-TYPE-LIABILITY)))
|
||||
(list "Equity" (list (cons 'type ACCT-TYPE-EQUITY)))
|
||||
@ -134,6 +135,7 @@
|
||||
(usd-bank (cdr (assoc "USD Bank" account-alist)))
|
||||
(wallet (cdr (assoc "Wallet" account-alist)))
|
||||
(income (cdr (assoc "Income" account-alist)))
|
||||
(gbp-income (cdr (assoc "Income-GBP" account-alist)))
|
||||
(expense (cdr (assoc "Expenses" account-alist)))
|
||||
(liability (cdr (assoc "Liabilities" account-alist)))
|
||||
(equity (cdr (assoc "Equity" account-alist)))
|
||||
@ -168,13 +170,22 @@
|
||||
(xaccAccountSetCommodity (cdr pair) (gnc-default-report-currency)))
|
||||
account-alist)
|
||||
|
||||
;; Here we set foreign banks' currencies
|
||||
;; Here we set foreign currencies
|
||||
|
||||
(gnc-commodity-set-user-symbol foreign2 "£")
|
||||
|
||||
(with-account
|
||||
gbp-bank
|
||||
(lambda ()
|
||||
(xaccAccountSetCode gbp-bank "01-GBP")
|
||||
(xaccAccountSetCommodity gbp-bank foreign2)))
|
||||
|
||||
(with-account
|
||||
gbp-income
|
||||
(lambda ()
|
||||
(xaccAccountSetCode gbp-income "01-GBP")
|
||||
(xaccAccountSetCommodity gbp-income foreign2)))
|
||||
|
||||
(with-account
|
||||
usd-bank
|
||||
(lambda ()
|
||||
@ -239,7 +250,9 @@
|
||||
;; run in modern times, otherwise these transactions will be mixed
|
||||
;; up with the old transactions above. The year end net bank balance
|
||||
;; should be (* 12 (+ 103 109 -22)) = $2280.
|
||||
;; there will also be a £51 income monthly, tested at end of file
|
||||
(for-each (lambda (m)
|
||||
(env-transfer env 08 (1+ m) YEAR gbp-income gbp-bank 51 #:description "£51 income")
|
||||
(env-transfer env 03 (1+ m) YEAR income bank 103 #:description "$103 income")
|
||||
(env-transfer env 15 (1+ m) YEAR bank expense 22 #:description "$22 expense")
|
||||
(env-transfer env 09 (1+ m) YEAR income bank 109 #:description "$109 income"))
|
||||
@ -728,13 +741,13 @@
|
||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'quarterly)
|
||||
(set-option! options "Sorting" "Show Informal Debit/Credit Headers" #t)
|
||||
(set-option! options "Sorting" "Show Account Description" #t)
|
||||
(let* ((sxml (options->sxml options "sorting=date")))
|
||||
(let* ((sxml (options->sxml options "sorting=date, friendly headers")))
|
||||
(test-equal "expense acc friendly headers"
|
||||
'("\n" "Expenses" "\n" "Expense" "\n" "Rebate")
|
||||
(get-row-col sxml 47 #f))
|
||||
(get-row-col sxml 69 #f))
|
||||
(test-equal "income acc friendly headers"
|
||||
'("\n" "Income" "\n" "Charge" "\n" "Income")
|
||||
(get-row-col sxml 69 #f)))
|
||||
(get-row-col sxml 91 #f)))
|
||||
|
||||
(set-option! options "Accounts" "Accounts" (list bank))
|
||||
(set-option! options "Display" "Totals" #f)
|
||||
@ -781,7 +794,7 @@
|
||||
(test-begin "subtotal table")
|
||||
|
||||
(let ((options (default-testing-options)))
|
||||
(set-option! options "Accounts" "Accounts" (list bank income expense))
|
||||
(set-option! options "Accounts" "Accounts" (list bank gbp-bank gbp-income income expense))
|
||||
(set-option! options "General" "Start Date" (cons 'relative 'start-cal-year))
|
||||
(set-option! options "General" "End Date" (cons 'relative 'end-cal-year))
|
||||
(set-option! options "Display" "Subtotal Table" #t)
|
||||
@ -794,18 +807,29 @@
|
||||
(list "Bank" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00"
|
||||
"$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$2,280.00")
|
||||
(get-row-col sxml 1 #f))
|
||||
(test-equal "summary gbp bank-row is correct"
|
||||
(list "GBP Bank" "£51.00" "£51.00" "£51.00" "£51.00" "£51.00" "£51.00"
|
||||
"£51.00" "£51.00" "£51.00" "£51.00" "£51.00" "£51.00" "£612.00")
|
||||
(get-row-col sxml 2 #f))
|
||||
(test-equal "summary expense-row is correct"
|
||||
(list "Expenses" "$22.00" "$22.00" "$22.00" "$22.00" "$22.00" "$22.00"
|
||||
"$22.00" "$22.00" "$22.00" "$22.00" "$22.00" "$22.00" "$264.00")
|
||||
(get-row-col sxml 2 #f))
|
||||
(get-row-col sxml 3 #f))
|
||||
(test-equal "summary income-row is correct"
|
||||
(list "Income" "-$212.00" "-$212.00" "-$212.00" "-$212.00" "-$212.00"
|
||||
"-$212.00" "-$212.00" "-$212.00" "-$212.00" "-$212.00" "-$212.00"
|
||||
"-$212.00" "-$2,544.00")
|
||||
(get-row-col sxml 3 #f))
|
||||
(get-row-col sxml 4 #f))
|
||||
(test-equal "summary gbp income-row is correct"
|
||||
(list "Income-GBP" "-£51.00" "-£51.00" "-£51.00" "-£51.00" "-£51.00" "-£51.00"
|
||||
"-£51.00" "-£51.00" "-£51.00" "-£51.00" "-£51.00" "-£51.00" "-£612.00")
|
||||
(get-row-col sxml 5 #f))
|
||||
(test-equal "summary gbp total-row is correct"
|
||||
(list "Grand Total" "£0.00")
|
||||
(get-row-col sxml 6 #f))
|
||||
(test-equal "summary total-row is correct"
|
||||
(list "Grand Total" "$0.00")
|
||||
(get-row-col sxml 4 #f)))
|
||||
(list "$0.00")
|
||||
(get-row-col sxml 7 #f)))
|
||||
|
||||
(set-option! options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 01 01 1969)))
|
||||
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
|
||||
|
@ -1375,9 +1375,11 @@ be excluded from periodic reporting.")
|
||||
(cons (gnc:make-html-table-cell/markup "total-number-cell" mon)
|
||||
result)))))))))
|
||||
|
||||
;; we only wish to add the first column into the grid.
|
||||
(if (pair? columns)
|
||||
(set! grid (grid-add grid row col (car columns))))
|
||||
;; take the first column of each commodity, add onto the subtotal grid
|
||||
(set! grid (grid-add grid row col
|
||||
(map (lambda (commodity)
|
||||
(retrieve-commodity (car columns) commodity))
|
||||
list-of-commodities)))
|
||||
|
||||
;; each commodity subtotal gets a separate line in the html-table
|
||||
;; each line comprises: indenting, first-column, data-columns
|
||||
@ -1689,17 +1691,17 @@ be excluded from periodic reporting.")
|
||||
;; grid data structure
|
||||
(define (make-grid)
|
||||
'())
|
||||
(define (cell-match? cell row col)
|
||||
(and (or (not row) (equal? row (vector-ref cell 0)))
|
||||
(or (not col) (equal? col (vector-ref cell 1)))))
|
||||
(define (grid-get grid row col) ; grid filter - get all row/col - if #f then retrieve whole row/col
|
||||
(filter
|
||||
(lambda (cell)
|
||||
(and (or (not row) (equal? row (vector-ref cell 0)))
|
||||
(or (not col) (equal? col (vector-ref cell 1)))))
|
||||
(lambda (cell) (cell-match? cell row col))
|
||||
grid))
|
||||
(define (grid-del grid row col) ; grid filter - del all row/col - if #f then delete whole row/col - CAREFUL!
|
||||
(filter
|
||||
(lambda (cell)
|
||||
(not (and (or (not row) (equal? row (vector-ref cell 0)))
|
||||
(or (not col) (equal? col (vector-ref cell 1))))))
|
||||
(not (cell-match? cell row col)))
|
||||
grid))
|
||||
(define (grid-rows grid)
|
||||
(delete-duplicates (map (lambda (cell) (vector-ref cell 0)) grid)))
|
||||
@ -1710,17 +1712,27 @@ be excluded from periodic reporting.")
|
||||
(set! grid (cons (vector row col data) grid)) ;add again. this is fine because the grid should
|
||||
grid) ;never have duplicate data in the trep.
|
||||
(define (grid->html-table grid list-of-rows list-of-cols)
|
||||
(define (make-table-cell row col)
|
||||
(define (row->num-of-commodities row)
|
||||
;; for a row, find the maximum number of commodities being stored
|
||||
(apply max
|
||||
(map (lambda (col)
|
||||
(let ((cell (grid-get grid row col)))
|
||||
(if (null? cell) 0
|
||||
(length (vector-ref (car cell) 2)))))
|
||||
(cons 'col-total list-of-cols))))
|
||||
(define (make-table-cell row col commodity-idx)
|
||||
(let ((cell (grid-get grid row col)))
|
||||
(if (pair? cell)
|
||||
(gnc:make-html-table-cell/markup "number-cell" (car (vector-ref (car cell) 2)))
|
||||
"")))
|
||||
(define (make-row row)
|
||||
(if (null? cell) ""
|
||||
(gnc:make-html-table-cell/markup "number-cell" (list-ref-safe (vector-ref (car cell) 2) commodity-idx)))))
|
||||
(define (make-row row commodity-idx)
|
||||
(append
|
||||
(list (if (eq? row 'row-total) (_ "Grand Total") (cdr row)))
|
||||
(map (lambda (col) (make-table-cell row col))
|
||||
(list (cond
|
||||
((positive? commodity-idx) "")
|
||||
((eq? row 'row-total) (_ "Grand Total"))
|
||||
(else (cdr row))))
|
||||
(map (lambda (col) (make-table-cell row col commodity-idx))
|
||||
list-of-cols)
|
||||
(list (make-table-cell row 'col-total))))
|
||||
(list (make-table-cell row 'col-total commodity-idx))))
|
||||
(let ((table (gnc:make-html-table)))
|
||||
(gnc:html-table-set-caption! table optname-grid)
|
||||
(gnc:html-table-set-col-headers! table (append (list "") (map cdr list-of-cols) (list (_ "Total"))))
|
||||
@ -1728,10 +1740,12 @@ be excluded from periodic reporting.")
|
||||
'attribute (list "class" "column-heading-right"))
|
||||
(for-each
|
||||
(lambda (row)
|
||||
(gnc:html-table-append-row! table (make-row row)))
|
||||
list-of-rows)
|
||||
(if (memq 'row-total (grid-rows grid))
|
||||
(gnc:html-table-append-row! table (make-row 'row-total)))
|
||||
(for-each (lambda (commodity-idx)
|
||||
(gnc:html-table-append-row! table (make-row row commodity-idx)))
|
||||
(iota (row->num-of-commodities row))))
|
||||
(if (memq 'row-total (grid-rows grid))
|
||||
(append list-of-rows '(row-total))
|
||||
list-of-rows))
|
||||
table))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;
|
||||
|
Loading…
Reference in New Issue
Block a user