IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

Robert Graham Merkel's transaction report patch.

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@3757 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas 2001-03-07 07:46:25 +00:00
parent 1ed0f8f4eb
commit e9cd05c521
3 changed files with 203 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
ChangeLog
View File

@ -1,3 +1,10 @@
2001-03-07 Robert Graham Merkel <rgmerk@mira.net>
* src/scm/report/transaction-report.scm: Added row colors to make things
look pretty. Comments on effectiveness appreciated.
* src/scm/html-table.scm: keep track of how many rows are in the table.
2001-03-06 Dave Peticolas <dave@krondo.com> 2001-03-06 Dave Peticolas <dave@krondo.com>
* src/scm/iso-4217-currencies.scm: remove duplicate currency * src/scm/iso-4217-currencies.scm: remove duplicate currency

33
src/scm/html-table.scm
View File

@ -29,6 +29,7 @@
row-headers row-headers
caption caption
data data
num-rows
style style
col-styles col-styles
row-styles row-styles
@ -145,6 +146,7 @@
;; ie (rowN rowN-1 . . . row0) ;; ie (rowN rowN-1 . . . row0)
;; So html-append-row is constant time but ;; So html-append-row is constant time but
;; html-prepend-row is slow ;; html-prepend-row is slow
0 ;; num-rows
(gnc:make-html-style-table) ;; style (gnc:make-html-style-table) ;; style
(make-hash-table 21) ;; col-styles (make-hash-table 21) ;; col-styles
(make-hash-table 21) ;; row-styles (make-hash-table 21) ;; row-styles
@ -280,8 +282,11 @@
(define (gnc:html-table-col-style table col) (define (gnc:html-table-col-style table col)
(hash-ref (gnc:html-table-col-styles table) col)) (hash-ref (gnc:html-table-col-styles table) col))
(define (gnc:html-table-num-rows table) (define gnc:html-table-num-rows
(length (gnc:html-table-data table))) (record-accessor <html-table> 'num-rows))
(define gnc:html-table-set-num-rows-internal!
(record-modifier <html-table> 'num-rows))
(define (gnc:html-table-num-columns table) (define (gnc:html-table-num-columns table)
(let ((max 0)) (let ((max 0))
@ -294,14 +299,26 @@
max)) max))
(define (gnc:html-table-append-row! table newrow) (define (gnc:html-table-append-row! table newrow)
(let ((dd (gnc:html-table-data table))) (let* ((dd (gnc:html-table-data table))
(current-num-rows (gnc:html-table-num-rows table))
(new-num-rows (+ current-num-rows 1)))
(set! dd (cons newrow dd)) (set! dd (cons newrow dd))
(gnc:html-table-set-data! table dd))) (gnc:html-table-set-num-rows-internal!
table
new-num-rows)
(gnc:html-table-set-data! table dd)
new-num-rows))
(define (gnc:html-table-prepend-row! table newrow) (define (gnc:html-table-prepend-row! table newrow)
(let ((dd (gnc:html-table-data table))) (let ((dd (gnc:html-table-data table))
(current-num-rows (gnc:html-table-num-rows table))
(new-num-rows (+ current-num-rows 1)))
(set! dd (append dd (list newrow))) (set! dd (append dd (list newrow)))
(gnc:html-table-set-data! table dd))) (gnc:html-table-set-num-rows-internal!
table
new-num-rows)
(gnc:html-table-set-data! table dd)
new-num-rows))
(define (gnc:html-table-set-cell! table row col . objects) (define (gnc:html-table-set-cell! table row col . objects)
(let ((rowdata #f) (let ((rowdata #f)
@ -315,8 +332,8 @@
((< i row) #f) ((< i row) #f)
(gnc:html-document-append-row! table '())) (gnc:html-document-append-row! table '()))
(set! rowdata (make-list (+ col 1) #f)) (set! rowdata (make-list (+ col 1) #f))
(gnc:html-document-append-row table rowdata) (gnc:html-document-append-row! table rowdata)
(set! l (length (gnc:html-table-data table))) (set! l (gnc:html-table-num-rows))
(set! row-loc (- (- l 1) row))) (set! row-loc (- (- l 1) row)))
(begin (begin
(set! row-loc (- (- l 1) row)) (set! row-loc (- (- l 1) row))

216
src/scm/report/transaction-report.scm
View File

@ -11,6 +11,7 @@
;; totally rewritten for new report generation code by Robert Merkel ;; totally rewritten for new report generation code by Robert Merkel
(let () (let ()
(define-syntax addto! (define-syntax addto!
(syntax-rules () (syntax-rules ()
@ -47,35 +48,56 @@
(tp-b (gnc:transaction-get-date-entered (gnc:split-get-parent b)))) (tp-b (gnc:transaction-get-date-entered (gnc:split-get-parent b))))
(timepair-same-year tp-a tp-b))) (timepair-same-year tp-a tp-b)))
(define (render-account-name-subheading split table) (define (set-last-row-style! table tag . rest)
(gnc:html-table-append-row! (let ((arg-list
table (cons table
(list (gnc:account-get-name (gnc:split-get-account split))))) (cons (- (gnc:html-table-num-rows table) 1) (cons tag rest)))))
(apply gnc:html-table-set-row-style! arg-list)))
(define (render-account-code-subheading split table) (define (render-account-name-subheading split table subheading-style)
(gnc:html-table-append-row! (begin
table (gnc:html-table-append-row!
(list (gnc:account-get-code (gnc:split-get-account split))))) table
(list (gnc:account-get-name (gnc:split-get-account split))))
(apply set-last-row-style! (cons table (cons "tr" subheading-style)))))
(define (render-corresponding-account-name-subheading split table) (define (render-account-code-subheading split table subheading-style)
(gnc:html-table-append-row! (begin (gnc:html-table-append-row!
table (list (gnc:split-get-corr-account-name split)))) table
(list (gnc:account-get-code (gnc:split-get-account split))))
(apply set-last-row-style! (cons table (cons "tr" subheading-style)))))
(define (render-corresponding-account-name-subheading
split table subheading-style)
(begin
(gnc:html-table-append-row!
table (list (gnc:split-get-corr-account-name split)))
(apply set-last-row-style! (cons table (cons "tr" subheading-style)))))
(define (render-corresponding-account-code-subheading split table) (define (render-corresponding-account-code-subheading
(gnc:html-table-append-row! split table subheading-style)
table (list (gnc:split-get-corr-account-code split)))) (begin
(gnc:html-table-append-row!
table (list (gnc:split-get-corr-account-code split)))
(apply set-last-row-style! (cons table (cons "tr" subheading-style)))))
(define (render-month-subheading split table) (define (render-month-subheading split table subheading-style)
(gnc:html-table-append-row! (begin (gnc:html-table-append-row!
table (list (strftime "%B %Y" (gnc:timepair->date table (list (strftime "%B %Y" (gnc:timepair->date
(gnc:transaction-get-date-entered (gnc:transaction-get-date-entered
(gnc:split-get-parent split))))))) (gnc:split-get-parent split))))))
(apply set-last-row-style! (cons table
(cons "tr" subheading-style)))))
(define (render-year-subheading split table)
(gnc:html-table-append-row! (define (render-year-subheading split table subheading-style)
table (list (strftime "%Y" (gnc:timepair->date (begin (gnc:html-table-append-row!
(gnc:transaction-get-date-entered table (list (strftime "%Y" (gnc:timepair->date
(gnc:split-get-parent split))))))) (gnc:transaction-get-date-entered
(gnc:split-get-parent split))))))
(apply set-last-row-style! (cons table
(cons "tr" subheading-style)))))
(let () (let ()
(define comp-funcs-assoc-list (define comp-funcs-assoc-list
@ -151,6 +173,7 @@
(define (used-running-balance columns-used) (define (used-running-balance columns-used)
(vector-ref columns-used 10)) (vector-ref columns-used 10))
(define columns-used-size 11)
(define (build-column-used options) (define (build-column-used options)
(define (opt-val section name) (define (opt-val section name)
(gnc:option-value (gnc:option-value
@ -218,7 +241,7 @@
(addto! heading-list (N_ "Balance"))) (addto! heading-list (N_ "Balance")))
(reverse heading-list))) (reverse heading-list)))
(define (add-split-row table split column-vector) (define (add-split-row table split column-vector row-style)
(let* ((row-contents '()) (let* ((row-contents '())
(parent (gnc:split-get-parent split)) (parent (gnc:split-get-parent split))
(account (gnc:split-get-account split)) (account (gnc:split-get-account split))
@ -250,18 +273,19 @@
(if (used-amount-single column-vector) (if (used-amount-single column-vector)
(addto! row-contents split-value)) (addto! row-contents split-value))
(if (used-amount-double-positive column-vector) (if (used-amount-double-positive column-vector)
(if (gnc:numeric-positive-p split-amount) (if (gnc:numeric-positive-p (gnc:gnc-monetary-amount split-value))
(addto! row-contents split-amount) (addto! row-contents split-value)
(addto! row-contents " "))) (addto! row-contents " ")))
(if (used-amount-double-negative column-vector) (if (used-amount-double-negative column-vector)
(if (gnc:numeric-negative-p split-amount) (if (gnc:numeric-negative-p (gnc:gnc-monetary-amount split-value))
(addto! row-contents (gnc:monetary-neg split-amount)) (addto! row-contents (gnc:monetary-neg split-value))
(addto! row-contents " "))) (addto! row-contents " ")))
(if (used-running-balance column-vector) (if (used-running-balance column-vector)
(addto! row-contents (addto! row-contents
(gnc:make-gnc-monetary currency (gnc:make-gnc-monetary currency
(gnc:split-get-balance split)))) (gnc:split-get-balance split))))
(gnc:html-table-append-row! table (reverse row-contents)) (gnc:html-table-append-row! table (reverse row-contents))
(apply set-last-row-style! (cons table (cons "tr" row-style)))
split-value)) split-value))
(define (lookup-sort-key sort-option) (define (lookup-sort-key sort-option)
@ -496,6 +520,40 @@ transferred from/to's code"))
(N_ "Display") (N_ "Totals") (N_ "Display") (N_ "Totals")
"l" (N_ "Display the totals?") #t)) "l" (N_ "Display the totals?") #t))
(gnc:register-trep-option
(gnc:make-color-option
(N_ "Colors") (N_ "Primary Subtotals/headings")
"a" (N_ "Background color for primary subtotals and headings")
(list #xff #xff #xff 0)
255
#f))
(gnc:register-trep-option
(gnc:make-color-option
(N_ "Colors") (N_ "Secondary Subtotals/headings")
"b" (N_ "Background color for secondary subtotals and headings")
(list #xff #xff #xff 0)
255
#f))
(gnc:register-trep-option
(gnc:make-color-option
(N_ "Colors") (N_ "Split Odd")
"c" (N_ "Background color for odd-numbered splits (or main splits in a\
multi-line report)")
(list #xff #xff #xff 0)
255
#f))
(gnc:register-trep-option
(gnc:make-color-option
(N_ "Colors") (N_ "Split Even")
"d" (N_ "Background color for even-numbered splits\
(or \"other\" splits in a\
multi-line report)")
(list #xff #xff #xff 0)
255
#f))
(gnc:options-set-default-section gnc:*transaction-report-options* (gnc:options-set-default-section gnc:*transaction-report-options*
"Report Options") "Report Options")
@ -528,14 +586,46 @@ transferred from/to's code"))
")" ")"
))) )))
(define (get-primary-subtotal-style options)
(let ((bgcolor (gnc:lookup-option options
(N_ "Colors")
(N_ "Primary Subtotals/headings"))))
(list 'attribute (list "bgcolor" (gnc:color-option->html bgcolor)))))
(define (get-secondary-subtotal-style options)
(let ((bgcolor (gnc:lookup-option options
(N_ "Colors")
(N_ "Secondary Subtotals/headings"))))
(list 'attribute (list "bgcolor" (gnc:color-option->html bgcolor)))))
(define (get-odd-row-style options)
(let ((bgcolor (gnc:lookup-option options
(N_ "Colors")
(N_ "Split Odd"))))
(list 'attribute (list "bgcolor" (gnc:color-option->html bgcolor)))))
(define (get-even-row-style options)
(let ((bgcolor (gnc:lookup-option options
(N_ "Colors")
(N_ "Split Even"))))
(list 'attribute (list "bgcolor" (gnc:color-option->html bgcolor)))))
(define (make-split-table splits options) (define (make-split-table splits options)
(define (add-subtotal-row table split used-columns subtotal-collector) (define (add-subtotal-row table split used-columns subtotal-collector)
(let ((currency-totals (subtotal-collector (define (blank-columns-required columns-used)
'format gnc:make-gnc-monetary #f))) (do ((i 0 (+ i 1))
(col-req 0 col-req))
((>= i columns-used-size) (- col-req 1))
(if (vector-ref columns-used i) (set! col-req (+ col-req 1)))))
(let ((currency-totals (subtotal-collector
'format gnc:make-gnc-monetary #f))
(blanks (make-list (blank-columns-required used-columns) #f)))
; (gnc:warn "Subtotal-collector" subtotal-collector) ; (gnc:warn "Subtotal-collector" subtotal-collector)
; (gnc:warn "Currency-totals:" currency-totals) ; (gnc:warn "Currency-totals:" currency-totals)
(for-each (lambda (currency) (for-each (lambda (currency)
(gnc:html-table-append-row! table (list currency))) (gnc:html-table-append-row!
table
(append blanks (list currency))))
currency-totals))) currency-totals)))
(define (get-primary-subtotal-pred options) (define (get-primary-subtotal-pred options)
@ -578,7 +668,7 @@ transferred from/to's code"))
(gnc:lookup-option options (N_ "Report Options") (N_ "Style"))) (gnc:lookup-option options (N_ "Report Options") (N_ "Style")))
'multi-line)) 'multi-line))
(define (add-other-split-rows split table used-columns) (define (add-other-split-rows split table used-columns row-style)
(define (other-rows-driver split parent table used-columns i) (define (other-rows-driver split parent table used-columns i)
(let ((current (gnc:transaction-get-split parent i))) (let ((current (gnc:transaction-get-split parent i)))
(gnc:debug "i" i) (gnc:debug "i" i)
@ -587,7 +677,7 @@ transferred from/to's code"))
((equal? current split) ((equal? current split)
(other-rows-driver split parent table used-columns (+ i 1))) (other-rows-driver split parent table used-columns (+ i 1)))
(else (begin (else (begin
(add-split-row table current used-columns) (add-split-row table current used-columns row-style)
(other-rows-driver split parent table used-columns (other-rows-driver split parent table used-columns
(+ i 1))))))) (+ i 1)))))))
@ -598,22 +688,34 @@ transferred from/to's code"))
table table
used-columns used-columns
multi-rows? multi-rows?
primary-subtotal-pred odd-row?
primary-subtotal-pred
secondary-subtotal-pred secondary-subtotal-pred
primary-subheading-renderer primary-subheading-renderer
secondary-subheading-renderer secondary-subheading-renderer
main-row-style
alternate-row-style
primary-subtotal-style
secondary-subtotal-style
primary-subtotal-collector primary-subtotal-collector
secondary-subtotal-collector secondary-subtotal-collector
total-collector) total-collector)
(if (null? splits) #f (if (null? splits) #f
(let* ((current (car splits)) (let* ((current (car splits))
(current-row-style (if multi-rows? main-row-style
(if odd-row? main-row-style
alternate-row-style)))
(rest (cdr splits)) (rest (cdr splits))
(next (if (null? rest) #f (next (if (null? rest) #f
(car rest))) (car rest)))
(split-value (add-split-row table current used-columns))) (split-value (add-split-row
table
current
used-columns
current-row-style)))
(if multi-rows? (if multi-rows?
(add-other-split-rows current table used-columns)) (add-other-split-rows
current table used-columns alternate-row-style))
(primary-subtotal-collector 'add (primary-subtotal-collector 'add
(gnc:gnc-monetary-commodity (gnc:gnc-monetary-commodity
split-value) split-value)
@ -634,7 +736,7 @@ transferred from/to's code"))
secondary-subtotal-collector) secondary-subtotal-collector)
(secondary-subtotal-collector 'reset #f #f) (secondary-subtotal-collector 'reset #f #f)
(if next (if next
(secondary-subheading-renderer current table)))) (secondary-subheading-renderer current table secondary-subtotal-style))))
(if (and primary-subtotal-pred (if (and primary-subtotal-pred
(or (not next) (or (not next)
(and next (and next
@ -643,15 +745,20 @@ transferred from/to's code"))
primary-subtotal-collector) primary-subtotal-collector)
(primary-subtotal-collector 'reset #f #f) (primary-subtotal-collector 'reset #f #f)
(if next (if next
(primary-subheading-renderer next table)))) (primary-subheading-renderer next table primary-subtotal-style))))
(do-rows-with-subtotals rest (do-rows-with-subtotals rest
table table
used-columns used-columns
multi-rows? multi-rows?
(not odd-row?)
primary-subtotal-pred primary-subtotal-pred
secondary-subtotal-pred secondary-subtotal-pred
primary-subheading-renderer primary-subheading-renderer
secondary-subheading-renderer secondary-subheading-renderer
main-row-style
alternate-row-style
primary-subtotal-style
secondary-subtotal-style
primary-subtotal-collector primary-subtotal-collector
secondary-subtotal-collector secondary-subtotal-collector
total-collector)))) total-collector))))
@ -661,19 +768,38 @@ transferred from/to's code"))
(multi-rows? (transaction-report-multi-rows-p options)) (multi-rows? (transaction-report-multi-rows-p options))
(primary-subtotal-pred (get-primary-subtotal-pred options)) (primary-subtotal-pred (get-primary-subtotal-pred options))
(secondary-subtotal-pred (get-secondary-subtotal-pred options)) (secondary-subtotal-pred (get-secondary-subtotal-pred options))
(primary-subheading-renderer (primary-subheading-renderer
(get-primary-subheading-renderer options)) (get-primary-subheading-renderer options))
(secondary-subheading-renderer (secondary-subheading-renderer
(get-secondary-subheading-renderer options))) (get-secondary-subheading-renderer options))
(primary-subtotal-style
(get-primary-subtotal-style options))
(secondary-subtotal-style
(get-secondary-subtotal-style options))
(odd-row-style
(get-odd-row-style options))
(even-row-style
(get-even-row-style options)))
(gnc:html-table-set-col-headers! (gnc:html-table-set-col-headers!
table table
(make-heading-list used-columns)) (make-heading-list used-columns))
; (gnc:warn "Splits:" splits) ; (gnc:warn "Splits:" splits)
(if (not (null? splits))
(if primary-subheading-renderer
(primary-subheading-renderer (car splits) table primary-subtotal-style))
(if secondary-subheading-renderer
(secondary-subheading-renderer (car splits) table secondary-subtotal-style)))
(do-rows-with-subtotals splits table used-columns (do-rows-with-subtotals splits table used-columns
multi-rows? primary-subtotal-pred multi-rows? #t primary-subtotal-pred
secondary-subtotal-pred secondary-subtotal-pred
primary-subheading-renderer primary-subheading-renderer
secondary-subheading-renderer secondary-subheading-renderer
odd-row-style
even-row-style
primary-subtotal-style
secondary-subtotal-style
(gnc:make-commodity-collector) (gnc:make-commodity-collector)
(gnc:make-commodity-collector) (gnc:make-commodity-collector)
(gnc:make-commodity-collector)) (gnc:make-commodity-collector))