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 reporting patch.

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@3715 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas
2001-02-28 06:31:49 +00:00
parent d60244ffad
commit af05f3af60
8 changed files with 236 additions and 105 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
ChangeLog
View File

@@ -1,3 +1,28 @@
2001-02-28 Robert Graham Merkel <rgmerk@mira.net>
* src/scm/report/transaction-report.scm: Formatting cleanups.
Gotta keep Dave P happy . . .
* src/scm/html-table.scm: html table data field list now stored in
*reverse* order, to make appending rows fast (prepending is now
O(n^2) however. If we want linear-time appends and prepends,
we'll need a Glist wrapper :) )
* src/scm/report/folio.scm: use renamed collector functions (dunno
why, code is dead . . .)
* src/scm/report/taxtxf.scm: use renamed collector functions (see
above)
* src/scm/report/average-balance.scm: changed to use renamed
collector functions.
* src/scm/commodity-utilities.scm: changed to used renamed
make-<foo>-collector functions.
* src/scm/report-utilities.scm (gnc:make-<foo>-collector): renamed
to prevent namespace pollution.
2001-02-27 James LewisMoss <jimdres@mindspring.com>
* src/test/test-xml-account.c (node_and_account_equal): Start

14
src/scm/commodity-utilities.scm
View File

@@ -76,8 +76,8 @@
;; numeric-collectors, where [abc] are numeric-collectors. See the
;; real variable names below.
(define (make-newrate unknown-coll un->known-coll known-pair)
(let ((a (make-numeric-collector))
(b (make-numeric-collector)))
(let ((a (gnc:make-numeric-collector))
(b (gnc:make-numeric-collector)))
(a 'add (unknown-coll 'total #f))
(b 'add
;; round to (at least) 6 significant digits
@@ -207,8 +207,8 @@
(if (not comm-list)
;; no, create sub-alist from scratch
(let ((pair (list transaction-comm
(cons (make-numeric-collector)
(make-numeric-collector)))))
(cons (gnc:make-numeric-collector)
(gnc:make-numeric-collector)))))
((caadr pair) 'add value-amount)
((cdadr pair) 'add share-amount)
(set! comm-list (list account-comm (list pair)))
@@ -233,8 +233,8 @@
(begin
(set!
pair (list (car foreignlist)
(cons (make-numeric-collector)
(make-numeric-collector))))
(cons (gnc:make-numeric-collector)
(gnc:make-numeric-collector))))
(set!
comm-list (list (car comm-list)
(cons pair (cadr comm-list))))
@@ -292,7 +292,7 @@
;; <gnc-monetary> with the domestic commodity and its corresponding
;; balance.
(define (gnc:sum-collector-commodity foreign domestic exchange-fn)
(let ((balance (make-commodity-collector)))
(let ((balance (gnc:make-commodity-collector)))
(foreign
'format
(lambda (curr val)

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

@@ -140,7 +140,11 @@
#f ;; col-headers
#f ;; row-headers
#f ;; caption
'() ;; data
'() ;; data
;; NB: data is stored in reverse row order!!
;; ie (rowN rowN-1 . . . row0)
;; So html-append-row is constant time but
;; html-prepend-row is slow
(gnc:make-html-style-table) ;; style
(make-hash-table 21) ;; col-styles
(make-hash-table 21) ;; row-styles
@@ -291,21 +295,32 @@
(define (gnc:html-table-append-row! table newrow)
(let ((dd (gnc:html-table-data table)))
(set! dd (append dd (list newrow)))
(set! dd (cons newrow dd))
(gnc:html-table-set-data! table dd)))
(define (gnc:html-table-prepend-row! table newrow)
(let ((dd (gnc:html-table-data table)))
(set! dd (cons newrow dd))
(set! dd (append dd (list newrow)))
(gnc:html-table-set-data! table dd)))
(define (gnc:html-table-set-cell! table row col . objects)
(let ((rowdata #f)
(row-loc #f)
(l (length (gnc:html-table-data table))))
;; ensure the row-data is there
(if (>= row l)
(set! rowdata (make-list (+ col 1) #f))
(set! rowdata (list-ref (gnc:html-table-data table) row)))
(begin
(do
(i l (+ i 1))
((< i row) #f)
(gnc:html-document-append-row! table '()))
(set! rowdata (make-list (+ col 1) #f))
(gnc:html-document-append-row table rowdata)
(set! l (length (gnc:html-table-data table)))
(set! row-loc (- (- l 1) row)))
(begin
(set! row-loc (- (- l 1) row))
(set! rowdata (list-ref (gnc:html-table-data table) row-loc))))
;; make a table-cell and set the data
(let ((tc (gnc:make-html-table-cell)))
@@ -315,73 +330,161 @@
;; add the row-data back to the table
(gnc:html-table-set-data!
table
(list-set-safe! (gnc:html-table-data table) row rowdata))))
(list-set-safe! (gnc:html-table-data table) row-loc rowdata))))
;(define (gnc:html-table-append-column! table newcol)
; (let ((colnum 0)
; (rownum 0)
; (rows (gnc:html-table-data table))
; (this-row #f)
; (new-row #f))
; ;; find out how many cols are already there in the deepest row
; (for-each
; (lambda (row)
; (let ((l (length row)))
; (if (> l colnum)
; (set! colnum l))))
; rows)
; ;; append the elements of 'newrow' to the rowumns
; (for-each-in-order
; (lambda (newelt)
; ;; find the row, or append one
; (if (not (null? rows))
; (begin
; (set! new-row #f)
; (set! this-row (car rows))
; (if (null? (cdr rows))
; (set! rows #f)
; (set! rows (cdr rows))))
; (begin
; (set! new-row #t)
; (set! this-row '())))
; ;; make sure the rowumn is long enough, then append the data
; (let loop ((l (length this-row))
; (r (reverse this-row)))
; (if (< l colnum)
; (loop (+ l 1) (cons #f r))
; (set! this-row
; (reverse (cons newelt r)))))
; (if new-row
; (gnc:html-table-append-row! table this-row)
; (list-set! (gnc:html-table-data table) rownum this-row))
; (set! rownum (+ 1 rownum)))
; (reverse newcol))))
(define (gnc:html-table-append-column! table newcol)
(let ((colnum 0)
(rownum 0)
(rows (gnc:html-table-data table))
(this-row #f)
(new-row #f))
;; find out how many cols are already there in the deepest row
(for-each
(lambda (row)
(let ((l (length row)))
(if (> l colnum)
(set! colnum l))))
rows)
;; append the elements of 'newrow' to the rowumns
(for-each-in-order
(lambda (newelt)
;; find the row, or append one
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
(define (maxwidth table-data)
(if (null? table-data) 0
(max (length (car table-data)) (maxwidth (cdr table-data)))))
;; widen an individual row to the required with and append element
(define (widen-and-append row element width)
(let ((current-width (length row))
(new-suffix (list element)))
(do
((i current-width (+ i 1)))
((< i width) #f)
(set! new-suffix (cons #f new-suffix)))
(append row new-suffix)))
; (define (widen-and-append row element width)
; (list "a" "b" "c"))
;; append the elements of newcol to each of the existing rows, widening
;; to width-to-make if necessary
(define (append-to-element newcol existing-data length-to-append width-to-make)
(if (= length-to-append 0)
(cons '() newcol)
(let*
((current-new (car newcol))
(current-existing (car existing-data))
(rest-new (cdr newcol))
(rest-existing (cdr existing-data))
(rest-result (append-to-element rest-new rest-existing
(- length-to-append 1))))
(cons (cons (widen-and-append
current-existing
current-new
width-to-make )
(car rest-result))
(cdr rest-result)))))
;; make sure the rowumn is long enough, then append the data
(let loop ((l (length this-row))
(r (reverse this-row)))
(if (< l colnum)
(loop (+ l 1) (cons #f r))
(set! this-row
(reverse (cons newelt r)))))
(if new-row
(gnc:html-table-append-row! table this-row)
(list-set! (gnc:html-table-data table) rownum this-row))
(set! rownum (+ 1 rownum)))
newcol)))
; (define (append-to-element newcol existing-data length-to-append width-to-make)
; (list (list "a" "b" "c") (list "d" "e" "f" "g")))
(let* ((existing-data (reverse (gnc:html-table-data table)))
(existing-length (length existing-data))
(width-to-make (+ (maxwidth existing-data) 1))
(newcol-length (length newcol)))
(if (<= newcol-length existing-length)
(gnc:html-table-set-data! table
(reverse! (car (append-to-element
newcol
existing-data
newcol-length
width-to-make))))
(let* ((temp-result (append-to-element
newcol
existing-data
existing-length
width-to-make))
(joined-table-data (car temp-result))
(remaining-elements (cdr temp-result)))
;; Invariant maintained - table data in reverse order
(gnc:html-table-set-data! table (reverse! joined-table-data))
(for-each
(lambda (element)
(gnc:html-table-append-row! table
(widen-and-append
'()
element
width-to-make)))
remaining-elements)
#f))))
(define (gnc:html-table-prepend-column! table newcol)
(let ((rows (gnc:html-table-data table))
(this-row #f)
(new-row #f)
(rownum 0))
(for-each-in-order
(lambda (elt)
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
(if new-row
(gnc:html-table-append-row! table (list elt))
(list-set! (gnc:html-table-data table) rownum
(cons elt this-row)))
(set! rownum (+ 1 rownum)))
newcol)))
;; returns a pair, the car of which is the prepending of newcol
;; and existing-data, and the cdr is the remaining elements of newcol
(define (prepend-to-element newcol existing-data length-to-append)
(if (= length-to-append 0) ('() . newcol)
(let*
((current-new (car newcol))
(current-existing (car existing-data))
(rest-new (cdr newcol))
(rest-existing (cdr existing-data))
(rest-result (prepend-to-element rest-new rest-existing
(- length-to-append 1))))
(cons
(cons (cons current-new current-existing) (car rest-result))
(cdr rest-result)))))
(let* (
(existing-data (reverse! (gnc:html-table-data table)))
(existing-length (length existing-data))
(newcol-length (length newcol))
)
(if (<= newcol-length existing-length)
(gnc:html-table-set-data!
(reverse! (car (prepend-to-element
newcol
existing-data
newcol-length))))
(let* ((temp-result (prepend-to-element
newcol
existing-data
existing-length))
(joined-table-data (car temp-result))
(remaining-elements (cdr temp-result)))
;; Invariant maintained - table data in reverse order
(gnc:html-table-set-data! table (reverse! joined-table-data))
(for-each
(lambda (element)
(gnc:html-table-append-row! table (list element)))
remaining-elements)
#f))))
(define (gnc:html-table-render table doc)
(let* ((retval '())
@@ -497,7 +600,7 @@
(set! colnum 0)
(set! rownum (+ 1 rownum))))
(gnc:html-table-data table)))
(reverse (gnc:html-table-data table))))
;; write the table end tag and pop the table style
(push (gnc:html-document-markup-end doc "table"))

24
src/scm/report-utilities.scm
View File

@@ -167,7 +167,7 @@
;;; It would be a logical extension to throw in a "slot" for x^2 so
;;; that you could also extract the variance and standard deviation
(define (make-stats-collector)
(define (gnc:make-stats-collector)
(let ;;; values
((value 0)
(totalitems 0)
@@ -202,7 +202,7 @@
('reset (reset-all))
(else (gnc:warn "bad stats-collector action: " action)))))))
(define (make-drcr-collector)
(define (gnc:make-drcr-collector)
(let ;;; values
((debits 0)
(credits 0)
@@ -233,7 +233,7 @@
;; This is a collector of values -- works similar to the stats-collector but
;; has much less overhead. It is used by the currency-collector (see below).
(define (make-value-collector)
(define (gnc:make-value-collector)
(let ;;; values
((value 0))
(lambda (action amount) ;;; Dispatch function
@@ -244,7 +244,7 @@
(else (gnc:warn "bad value-collector action: " action))))))
;; Same as above but with gnc:numeric
(define (make-numeric-collector)
(define (gnc:make-numeric-collector)
(let ;;; values
((value (gnc:numeric-zero)))
(lambda (action amount) ;;; Dispatch function
@@ -252,9 +252,9 @@
('add (if (gnc:gnc-numeric? amount)
(set! value (gnc:numeric-add-fixed amount value))
(gnc:warn
"numeric-collector called with wrong argument: " amount)))
"gnc:numeric-collector called with wrong argument: " amount)))
('total value)
(else (gnc:warn "bad numeric-collector action: " action))))))
(else (gnc:warn "bad gnc:numeric-collector action: " action))))))
;; A commodity collector. This is intended to handle multiple
;; currencies' amounts. The amounts are accumulated via 'add, the
@@ -292,7 +292,7 @@
;; (internal) 'list #f #f: get the association list of
;; commodity->numeric-collector
(define (make-commodity-collector)
(define (gnc:make-commodity-collector)
(let
;; the association list of (commodity -> value-collector) pairs.
((commoditylist '()))
@@ -305,7 +305,7 @@
(if (not pair)
(begin
;; create a new pair, using the gnc:numeric-collector
(set! pair (list commodity (make-numeric-collector)))
(set! pair (list commodity (gnc:make-numeric-collector)))
;; and add it to the alist
(set! commoditylist (cons pair commoditylist))))
;; add the value
@@ -416,7 +416,7 @@
(if include-children?
(gnc:group-get-comm-balance-at-date
(gnc:account-get-children account) date)
(make-commodity-collector)))
(gnc:make-commodity-collector)))
(query (gnc:malloc-query))
(splits #f))
@@ -455,7 +455,7 @@
;; commodity-collector.
(define (gnc:accounts-get-balance-helper
accounts get-balance-fn reverse-balance-fn)
(let ((collector (make-commodity-collector)))
(let ((collector (gnc:make-commodity-collector)))
(for-each
(lambda (acct)
(collector (if (reverse-balance-fn acct)
@@ -490,7 +490,7 @@
;; returns a commodity-collector
(define (gnc:group-get-comm-balance-at-date group date)
(let ((this-collector (make-commodity-collector)))
(let ((this-collector (gnc:make-commodity-collector)))
(for-each
(lambda (x) (this-collector 'merge x #f))
(gnc:group-map-accounts
@@ -533,7 +533,7 @@
;; the version which returns a commodity-collector
(define (gnc:group-get-comm-balance-interval group from to)
(let ((this-collector (make-commodity-collector)))
(let ((this-collector (gnc:make-commodity-collector)))
(for-each (lambda (x) (this-collector 'merge x #f))
(gnc:group-map-accounts
(lambda (account)

6
src/scm/report/average-balance.scm
View File

@@ -133,9 +133,9 @@
;; worrying about currency ATM :(
(define (analyze-splits splits start-bal start-date end-date interval)
(let* ((minmax-accum (make-stats-collector))
(stats-accum (make-stats-collector))
(gain-loss-accum (make-drcr-collector))
(let* ((minmax-accum (gnc:make-stats-collector))
(stats-accum (gnc:make-stats-collector))
(gain-loss-accum (gnc:make-drcr-collector))
(interval-start start-date)
(interval-end (incdate start-date interval))
(last-balance start-bal)

4
src/scm/report/folio.scm
View File

@@ -37,8 +37,8 @@
(define (report-rows)
(define total-value (make-stats-collector))
(define total-cost (make-stats-collector))
(define total-value (gnc:make-stats-collector))
(define total-cost (gnc:make-stats-collector))
(define blank-row
(list "&nbsp" "&nbsp" "&nbsp" "&nbsp" "&nbsp" "&nbsp" "&nbsp"))

2
src/scm/report/taxtxf.scm
View File

@@ -139,7 +139,7 @@
(let ((level-collector (make-vector num-levels)))
(do ((i 0 (+ i 1)))
((= i num-levels) i)
(vector-set! level-collector i (make-stats-collector)))
(vector-set! level-collector i (gnc:make-stats-collector)))
level-collector))
;; Just a private scope.

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

@@ -92,7 +92,9 @@
(vector 'by-date
split-same-month-p render-month-subheading))
(cons 'date-yearly
(vector 'by-date split-same-year-p render-year-subheading))
(vector 'by-date
split-same-year-p
render-year-subheading))
(cons 'corresponding-acc-name
(vector 'by-corr-account-name #f #f))
(cons 'corresponding-acc-code
@@ -367,7 +369,8 @@
(vector 'corresponding-acc-name-subtotal
(N_ "Transfer from/to (w/subtotal) by code ")
(N_ "Sort and subtotal by account transferred from/to's code"))
(N_ "Sort and subtotal by account transferred \
from/to's code"))
(vector 'corresponding-acc-code
(N_ "Transfer from/to code")
@@ -375,7 +378,8 @@
(vector 'corresponding-acc-code-subtotal
(N_ "Transfer from/to (w/subtotal)")
(N_ "Sort and subtotal by account transferred from/to's code"))
(N_ "Sort and subtotal by account \
transferred from/to's code"))
(vector 'amount
(N_ "Amount")
@@ -465,7 +469,8 @@
(gnc:register-trep-option
(gnc:make-simple-boolean-option
(N_ "Display") (N_ "Other Account")
"h" (N_ "Display the other account? (if this is a split transaction, this parameter is guessed).") #f))
"h" (N_ "Display the other account?\
(if this is a split transaction, this parameter is guessed).") #f))
(gnc:register-trep-option
(gnc:make-simple-boolean-option
@@ -638,8 +643,7 @@
(not (secondary-subtotal-pred current next)))))
(begin (add-subtotal-row table current used-columns
secondary-subtotal-collector)
(set! secondary-subtotal-collector
(make-commodity-collector))
(secondary-subtotal-collector 'reset #f #f)
(if next
(secondary-subheading-renderer current table))))
(if (and primary-subtotal-pred
@@ -648,8 +652,7 @@
(not (primary-subtotal-pred current next)))))
(begin (add-subtotal-row table current used-columns
primary-subtotal-collector)
(set! primary-subtotal-collector
(make-commodity-collector))
(primary-subtotal-collector 'reset #f #f)
(if next
(primary-subheading-renderer next table))))
(do-rows-with-subtotals rest
@@ -682,10 +685,10 @@
secondary-subtotal-pred
primary-subheading-renderer
secondary-subheading-renderer
(make-commodity-collector)
(make-commodity-collector)
(make-commodity-collector))
table))
(gnc:make-commodity-collector)
(gnc:make-commodity-collector)
(gnc:make-commodity-collector))
table))
(define (trep-renderer report-obj)
(define (opt-val section name)
@@ -703,7 +706,7 @@
(secondary-key (opt-val "Sorting" "Secondary Key"))
(secondary-order (opt-val "Sorting" "Secondary Sort Order"))
(splits '())
(table '())
(table '())
(query (gnc:malloc-query)))
(gnc:query-set-group query (gnc:get-current-group))