From 711e3fd62fd5162bdc00657dacab782150cd71d3 Mon Sep 17 00:00:00 2001 From: Dave Peticolas Date: Sat, 15 Apr 2000 05:46:07 +0000 Subject: [PATCH] *** empty log message *** git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2185 57a11ea4-9604-0410-9ed3-97b8803252fd --- src/scm/html-generator.scm | 284 +++++++++++--- src/scm/report-utilities.scm | 24 ++ src/scm/report/budget-report.scm | 485 +++++++++++++++++------- src/scm/report/report-list.scm | 1 + src/scm/report/transaction-report-2.scm | 295 ++++++++++++++ 5 files changed, 901 insertions(+), 188 deletions(-) create mode 100644 src/scm/report/transaction-report-2.scm diff --git a/src/scm/html-generator.scm b/src/scm/html-generator.scm index fa57b9441a..864f23436a 100644 --- a/src/scm/html-generator.scm +++ b/src/scm/html-generator.scm @@ -80,6 +80,8 @@ ;; report-sort-spec-structure ;; get-value-proc: given the entry, finds the value. Required. ;; sort-pred: usually <. Required. +;; equal-pred: usually =. Required. This is used during sorting for +;; multi-key sorting. ;; subsection-pred: often = or #f. Returns #t if both values are in ;; the same subsection ;; subsection-title-proc: returns the title of the subsection given a @@ -87,7 +89,8 @@ (define report-sort-spec-structure (make-record-type "report-sort-spec-structure" - '(get-value-proc sort-pred subsection-pred subsection-title-proc))) + '(get-value-proc sort-pred equal-pred subsection-pred + subsection-title-proc))) (define make-report-sort-spec (record-constructor report-sort-spec-structure)) @@ -98,6 +101,9 @@ (define report-sort-spec-get-sort-pred (record-accessor report-sort-spec-structure 'sort-pred)) +(define report-sort-spec-get-equal-pred + (record-accessor report-sort-spec-structure 'equal-pred)) + (define report-sort-spec-get-subsection-pred (record-accessor report-sort-spec-structure 'subsection-pred)) @@ -134,45 +140,45 @@ (define report-spec-get-first-last-preference (record-accessor report-spec-structure 'first-last-preference)) -;; convert table to html. Subentries follow entries -(define (html-table-entries-first lst specs false-proc) - (map ;; map-in-order when it's fixed - (lambda (line) - (html-table-row-group - (list - (html-table-row-manual (html-table-do-entry line specs)) +;; convert a list of entries into html +(define (html-table-render-entries entry-list specs sort-specs line-render-proc false-proc) + (html-table-do-subsection + (html-table-sort entry-list sort-specs) + specs sort-specs line-render-proc false-proc 1)) + +;; the next 3 functions can be passed to html-table-render-entries + +;; convert an entry into html. subentries follow entries +(define (html-table-entry-render-entries-first line specs false-proc) + (html-table-row-group + (cons + (html-table-row-manual (html-table-do-entry line specs)) + (map + html-table-row-manual + (html-table-collect-subentries line specs false-proc))))) + +;; convert an entry into html. first subentry is merged with the entry +(define (html-table-entry-render-subentries-merged line specs false-proc) + (let ((subs-lines (html-table-collect-subentries line specs false-proc))) + (html-table-row-group + (list + (html-table-row-manual (map - html-table-row-manual - (html-table-collect-subentries line specs false-proc))))) - lst)) + (lambda (entry sub) + (if (not sub) entry sub)) + (html-table-do-entry line specs) + (car subs-lines))) + (map html-table-row-manual (cdr subs-lines)))))) -;; convert table to html. The first subentry is merged with the -;; entries on the first line. -(define (html-table-subentries-merged lst specs false-proc) - (map ;; map-in-order - (lambda (line) - (let ((subs-lines (html-table-collect-subentries line specs false-proc))) - (html-table-row-group - (list - (html-table-row-manual - (map - (lambda (entry sub) - (if (not sub) entry sub)) - (html-table-do-entry line specs) - (car subs-lines))) - (map html-table-row-manual (cdr subs-lines)))))) - lst)) -;; convert table to html. Entries only -(define (html-table-entries-only lst specs false-proc) - (map ;; map-in-order - (lambda (line) - (html-table-row-manual (html-table-do-entry line specs))) - lst)) +;; convert an entry into html. ignore sub entries +(define (html-table-entry-render-entries-only line specs false-proc) + (html-table-row-group + (html-table-row-manual (html-table-do-entry line specs)))) ;; convert totals to html (define (html-table-totals lst specs) - (html-table-row-manual + (html-table-totals-row (map (lambda (spec) (cond ((report-spec-get-total-html-proc spec) @@ -185,20 +191,165 @@ ;; convert headers to html (define (html-table-headers specs) - (map - (lambda (spec) - (html-header-cell - (report-spec-get-header spec))) - specs)) + (html-table-headers-row + (map + (lambda (spec) + (html-header-cell + (report-spec-get-header spec))) + specs))) + +;;;;;;;;;;;;;;;; +;; the rest are just helper functions + +;; convert subtotals to html +(define (html-table-subtotals lst sort-spec specs depth) + (html-table-subtotals-row + depth + (map + (lambda (spec) + (cond ((report-spec-get-subtotal-html-proc spec) + ((report-spec-get-subtotal-html-proc spec) + (apply + (report-spec-get-total-proc spec) + (map (report-spec-get-get-value-proc spec) lst)))) + (else #f))) + specs))) + + +;(define (html-table-subtotals subtotals sort-spec specs depth) +; (html-table-subtotals-row +; depth +; (map +; (lambda (subtotal spec) +; (cond +; ((report-spec-get-subtotal-html-proc spec) +; ((report-spec-get-subtotal-html-proc spec) subtotal)) +; (else #f))) +; subtotals specs))) + +;(define (html-table-init-subtotals specs sort-specs) +; (map +; (lambda (sort-spec) +; (map +; (lambda (spec) 0.0) +; specs)) +; sort-specs)) + +;(define (html-table-accumulate-subtotals subtotals specs sort-specs line) +; (map +; (lambda (subtotal sort-spec) +; (cond +; ((report-sort-spec-get-subsection-pred sort-spec) +; (map +; (lambda (sub spec) +; (cond +; ((report-spec-get-subtotal-html-proc spec) +; (+ sub ((report-spec-get-get-value-proc spec) line))) +; (else 0.0))) +; subtotal specs)) +; (else '()))) +; subtotals sort-specs)) + +(define (html-table-sort lst sort-specs) + (sort lst (html-table-make-sort-pred sort-specs))) + +(define (html-table-do-subsection lst specs sort-specs line-render-proc false-proc depth) + (cond + ((null? sort-specs) + (map + (lambda (line) (line-render-proc line specs false-proc)) + lst)) + (else + (let loop ((lst2 lst)) + (cond + ((null? lst2) '()) + (else + (let* ((front '()) + (back '()) + (sort-spec (car sort-specs)) + (subsection-pred (report-sort-spec-get-subsection-pred sort-spec)) + (get-value-proc (report-sort-spec-get-get-value-proc sort-spec)) + (value1 (get-value-proc (car lst2)))) + (cond + (subsection-pred + (set! front + (remove-if-not + (lambda (line) + (subsection-pred value1 (get-value-proc line))) + lst2)) + (set! back (set-difference lst2 front))) + (else + (set! front lst2) + (set! back '()))) + (list + (cond ((report-sort-spec-get-subsection-title-proc sort-spec) + (html-table-subsection-title + ((report-sort-spec-get-subsection-title-proc sort-spec) + (get-value-proc (car front))) + depth)) + (else '())) + (html-table-do-subsection + front specs (cdr sort-specs) line-render-proc false-proc (+ depth 1)) + (cond (subsection-pred + (html-table-subtotals front sort-spec specs depth)) + (else '())) + (loop back))))))))) + + +;(define (html-table-do-subsection-stuff line1 line2 sort-specs report-specs subtotals) +; (let loop ((depth 1) +; (specs sort-specs) +; (totals subtotals)) +; (cond +; ((null? specs) '()) +; ((not line1) +; (if (report-sort-spec-get-subsection-title-proc (car specs)) +; (cons +; (html-table-subsection-title +; ((report-sort-spec-get-subsection-title-proc (car specs)) +; ((report-sort-spec-get-get-value-proc (car specs)) line2)) +; depth) +; (loop (+ depth 1) (cdr specs) (cdr totals))) +; (loop (+ depth 1) (cdr specs) (cdr totals)))) +; (else +; (cond +; ((report-sort-spec-get-subsection-pred (car specs)) +; (let ((get-value-proc (report-sort-spec-get-get-value-proc (car specs))) +; (subtitle-proc (report-sort-spec-get-subsection-title-proc (car specs)))) +; (cond +; ((not +; ((report-sort-spec-get-subsection-pred (car specs)) +; (get-value-proc line1) (get-value-proc line2))) +; (if subtitle-proc +; (cons +; (html-table-subtotals (car totals) (car specs) report-specs depth) +; (cons +; (html-table-subsection-title +; (subtitle-proc (get-value-proc line2)) depth) +; (loop (+ depth 1) (cdr specs) (cdr totals)))) +; (loop (+ depth 1) (cdr specs) (cdr totals)))) +; (else (loop (+ depth 1) (cdr specs) (cdr totals)))))) +; (else '())))))) + +(define (html-table-make-sort-pred sort-specs) + (lambda (entry1 entry2) + (let loop ((specs sort-specs)) + (cond ((null? specs) #f) + (else + (let* ((spec (car specs)) + (gv-proc (report-sort-spec-get-get-value-proc spec)) + (value1 (gv-proc entry1)) + (value2 (gv-proc entry2))) + (cond (((report-sort-spec-get-sort-pred spec) value1 value2) #t) + (((report-sort-spec-get-equal-pred spec) value1 value2) + (loop (cdr specs))) + (else #f)))))))) ;; converts from col order to row order. ;; ex. ((a b) (c d) (e f)) -> ((a c e) (b d f)) (define (col-list->row-list lst) (apply map list lst)) -;;;;;;;;;;;;;;;; -;; the rest are just helper functions - ;; converts subentries into html and collects into a list of lists of ;; html cells. (define (html-table-collect-subentries line specs false-proc) @@ -222,20 +373,59 @@ (else #f))) specs)) +(define (html-table-headers-row headers) + (list + "" + headers + "\n")) + +(define (html-table-totals-row cells) + (list + "" + (map + (lambda (cell) + (cond (cell cell) + (else html-blank-cell))) + cells) + "\n")) + +(define (html-table-subtotals-row depth cells) + (list + "" + (map + (lambda (cell) + (cond (cell cell) + (else html-blank-cell))) + cells) + "\n")) + + (define (html-table-row-manual items) (list - "" + "" (map (lambda (cell) (cond (cell cell) (else html-blank-cell))) items) - "")) + "\n")) + +(define (html-table-subsection-title title depth) + (list "" title "")) ;; help! this doesn't work! I want something to group several rows ;; together so that an "entry" is noticably one unit. -(define (html-table-row-group rows) - (list "" rows "")) +;; netscape & our html widget do not support tbody. +;;(define (html-table-row-group rows) +;; (list "" rows "")) + +(define html-table-group-color "#99ccff") + +(define (html-table-row-group row) + (if (string=? html-table-group-color "#99ccff") + (set! html-table-group-color "#ffffff") + (set! html-table-group-color "#99ccff")) + row) (define (html-strong html) (if html @@ -328,7 +518,7 @@ "")) (define (html-start-table) - (list "")) + (list "
")) ;; border=2 rules=\"groups\" (define (html-end-table) (list "
")) diff --git a/src/scm/report-utilities.scm b/src/scm/report-utilities.scm index 91d3ca672e..7bd6e0c8ac 100644 --- a/src/scm/report-utilities.scm +++ b/src/scm/report-utilities.scm @@ -72,12 +72,26 @@ (gnc:for-loop thunk (+ first step) last step)) #f)) +(define (gnc:map-for thunk first last step) + (if (< first last) + (cons + (thunk first) + (gnc:map-for thunk (+ first step) last step)) + '())) + ;;; applies thunk to each split in account account (define (gnc:for-each-split-in-account account thunk) (gnc:for-loop (lambda (x) (thunk (gnc:account-get-split account x))) 0 (gnc:account-get-split-count account) 1)) +;;; applies thunk to each split in account account +(define (gnc:map-splits-in-account thunk account) + (gnc:map-for (lambda (x) + (thunk (gnc:account-get-split account x))) + 0 (gnc:account-get-split-count account) 1)) + + (define (gnc:group-map-accounts thunk group) (let ((num-accounts (gnc:group-get-num-accounts group))) (let loop @@ -99,6 +113,16 @@ (gnc:ith-split split-array (+ index 1)) (cons split slist))))) +;; pull a scheme list of splits from an account +(define (gnc:account-get-split-list account) + (let ((num-splits (gnc:account-get-split-count account))) + (let loop ((index 0)) + (if (= index num-splits) + '() + (cons + (gnc:account-get-split account index) + (loop (+ index 1))))))) + ;; Pull a scheme list of accounts (including subaccounts) from group grp (define (gnc:group-get-account-list grp) (if (pointer-token-null? grp) diff --git a/src/scm/report/budget-report.scm b/src/scm/report/budget-report.scm index b395a06cb4..aef733433b 100644 --- a/src/scm/report/budget-report.scm +++ b/src/scm/report/budget-report.scm @@ -30,7 +30,7 @@ (define budget-entry-structure (make-record-type "budget-entry-structure" - '(description accounts subentries action))) + '(description accounts filter-pred subentries action))) (define budget-subentry-structure (make-record-type @@ -75,11 +75,20 @@ (define make-nominal-mechanism (record-constructor budget-nominal-mechanism-structure)) +;;; useful filter-pred's for a budget entry + +(define (budget-filter-pred-debit split budget-line) + (> (gnc:split-get-value split) 0)) + ;; make-budget-entry: ;; 1: description, ;; 2: list of accounts -;; 3: list of subentries. -;; 4: action: #t: normal budget line +;; 3: filter pred: given the split and the budget line, return #t if +;; the split should be added to the budget. (before +;; calling, the transaction is already filtered on +;; date & accounts). +;; 4: list of subentries. +;; 5: action: #t: normal budget line ;; 'gnc:budget-comment: display, but do not total ;; #f: ignore @@ -119,62 +128,169 @@ (define gnc:budget-entries (list - (make-budget-entry "gross" '("Income:Gross Employment Income") (list - (make-budget-subentry #f -342.27 1 'gnc:budget-month (make-bill-mechanism -1 2))) #t) - (make-budget-entry "bank interest" '("Expense:Bank Charges:Interest") (list - (make-budget-subentry "interest loc" 40 1 'gnc:budget-month (make-bill-mechanism -4 0)) - (make-budget-subentry "interest rrsp" 40 1 'gnc:budget-month (make-bill-mechanism 8 10))) #t) - (make-budget-entry "cell phone" '("Expense:Bills:Cell phone") (list - (make-budget-subentry #f 60 1 'gnc:budget-month (make-bill-mechanism -4 -1))) #t) - (make-budget-entry "hydro" '("Expense:Bills:Hydro") (list - (make-budget-subentry #f 20 1 'gnc:budget-month (make-bill-mechanism 15 19))) #t) - (make-budget-entry "life insurance" '("Expense:Bills:Life Insurance") (list - (make-budget-subentry #f 15 1 'gnc:budget-month (make-bill-mechanism 1 3))) #t) - (make-budget-entry "diesel" '("Expense:Car:Diesel") (list - (make-budget-subentry #f 30 6 'gnc:budget-week (make-recurring-mechanism))) #t) - (make-budget-entry "licenses" '("Expense:Car:Licenses") (list - (make-budget-subentry #f 1000 1 'gnc:budget-year (make-bill-mechanism -122 -108))) #t) - (make-budget-entry "car maintenance" '("Expense:Car:Maintenance") (list - (make-budget-subentry #f 100 6 'gnc:budget-month (make-recurring-mechanism))) #t) - (make-budget-entry "car misc" '("Expense:Car:Miscellaneous") (list - (make-budget-subentry #f 5 1 'gnc:budget-week (make-recurring-mechanism))) #t) - (make-budget-entry "charitable" - '("Expense:Charitable:Non-taxable" "Expense:Charitable:Taxable") (list - (make-budget-subentry #f 200 1 'gnc:budget-year (make-recurring-mechanism))) #t) - (make-budget-entry "entertainment" - '("Expense:Entertainment:Beer (out)" "Expense:Entertainment:Cover" - "Expense:Entertainment:Date" "Expense:Entertainment:Dining" - "Expense:Entertainment:Dues" "Expense:Entertainment:Goodwill" - "Expense:Entertainment:Liquor (home)") (list - (make-budget-subentry #f 50 1 'gnc:budget-week (make-recurring-mechanism))) #t) - (make-budget-entry "groceries" '("Expense:Food:Groceries") (list - (make-budget-subentry #f 125 1 'gnc:budget-month (make-recurring-mechanism))) #t) - (make-budget-entry "junk food" '("Expense:Food:Junk") (list - (make-budget-subentry #f 0.5 1 'gnc:budget-day (make-recurring-mechanism))) #t) - (make-budget-entry "lunch" '("Expense:Food:Lunch") (list - (make-budget-subentry #f 8 1 'gnc:budget-day (make-recurring-mechanism))) #t) - (make-budget-entry "gifts" '("Expense:Gifts") (list - (make-budget-subentry #f 400 1 'gnc:budget-year (make-recurring-mechanism)) - (make-budget-subentry "xmas" 400 1 'gnc:budget-year (make-bill-mechanism -30 -5))) #t) - (make-budget-entry "rent" '("Expense:Household:Rent") (list - (make-budget-subentry #f 312.50 1 'gnc:budget-month (make-bill-mechanism 1 2))) #t) - (make-budget-entry "house junk" '("Expense:Household:Stuff") (list - (make-budget-subentry #f 25 1 'gnc:budget-month (make-recurring-mechanism))) #t) - (make-budget-entry "medical" '("Expense:Medical:Dental" "Expense:Medical:Optical" - "Expense:Medical:Other") (list - (make-budget-subentry #f 1000 1 'gnc:budget-year (make-contingency-mechanism))) #t) - (make-budget-entry "clothes" '("Expense:Personal:Clothes") (list - (make-budget-subentry #f 150 3 'gnc:budget-month (make-recurring-mechanism))) #t) - (make-budget-entry "hygeine" '("Expense:Personal:Personal maintenance") (list - (make-budget-subentry #f 30 1 'gnc:budget-month (make-recurring-mechanism))) #t) - (make-budget-entry "newspapers" '("Expense:Stuff:Newspapers") (list - (make-budget-subentry #f 20.52 1 'gnc:budget-month (make-bill-mechanism 14 14))) #t) - (make-budget-entry "stuff" '("Expense:Stuff:CD's" "Expense:Stuff:Electronic entertainment" - "Expense:Stuff:Fiction" "Expense:Stuff:Games" - "Expense:Stuff:Magazines" "Expense:Stuff:Musical Equipment" - "Expense:Stuff:Software" "Expense:Stuff:Sports equipment" - "Expense:Stuff:Videos") (list - (make-budget-subentry #f 250 1 'gnc:budget-month (make-recurring-mechanism))) #t))) + (make-budget-entry + "gross" '("Income:Gross Employment Income") #f + (list + (make-budget-subentry #f -9999999.99 1 'gnc:budget-month + (make-bill-mechanism -1 2))) #t) + (make-budget-entry + "bank interest" '("Expense:Bank Charges:Interest") #f + (list + (make-budget-subentry #f 40 1 'gnc:budget-month + (make-bill-mechanism -4 0))) #t) + (make-budget-entry + "bank feed" '("Expense:Bank Charges:Fees") #f + (list + (make-budget-subentry #f 50 1 'gnc:budget-year + (make-bill-mechanism 27 27))) #t) + (make-budget-entry + "cell phone" '("Expense:Bills:Cell phone") #f + (list + (make-budget-subentry #f 60 1 'gnc:budget-month + (make-bill-mechanism -4 -1))) #t) + (make-budget-entry + "hydro" '("Expense:Bills:Hydro") #f + (list + (make-budget-subentry #f 20 1 'gnc:budget-month + (make-bill-mechanism 15 19))) #t) + (make-budget-entry + "life insurance" '("Expense:Bills:Life Insurance") #f + (list + (make-budget-subentry #f 15 1 'gnc:budget-month + (make-bill-mechanism 1 3))) #t) + (make-budget-entry + "diesel" '("Expense:Car:Diesel") #f + (list + (make-budget-subentry #f 30 4 'gnc:budget-week + (make-recurring-mechanism))) #t) + (make-budget-entry + "licenses" '("Expense:Car:Licenses") #f + (list + (make-budget-subentry #f 1000 1 'gnc:budget-year + (make-bill-mechanism -122 -108))) #t) + (make-budget-entry + "car maintenance" '("Expense:Car:Maintenance") #f + (list + (make-budget-subentry #f 100 6 'gnc:budget-month + (make-recurring-mechanism))) #t) + (make-budget-entry + "car misc" '("Expense:Car:Miscellaneous") #f + (list + (make-budget-subentry #f 5 1 'gnc:budget-week + (make-recurring-mechanism))) #t) + (make-budget-entry + "charitable" '("Expense:Charitable:Non-taxable" + "Expense:Charitable:Taxable") #f + (list + (make-budget-subentry #f 200 1 'gnc:budget-year + (make-recurring-mechanism))) #t) + (make-budget-entry + "entertainment" '("Expense:Entertainment:Beer (out)" + "Expense:Entertainment:Cover" + "Expense:Entertainment:Date" + "Expense:Entertainment:Dining" + "Expense:Entertainment:Dues" + "Expense:Entertainment:Goodwill" + "Expense:Entertainment:Liquor (home)") #f + (list + (make-budget-subentry #f 50 1 'gnc:budget-week + (make-recurring-mechanism))) #t) + (make-budget-entry + "groceries" '("Expense:Food:Groceries") #f + (list + (make-budget-subentry #f 125 1 'gnc:budget-month + (make-recurring-mechanism))) #t) + (make-budget-entry + "junk food" '("Expense:Food:Junk") #f + (list + (make-budget-subentry #f 0.5 1 'gnc:budget-day + (make-recurring-mechanism))) #t) + (make-budget-entry + "lunch" '("Expense:Food:Lunch") #f + (list + (make-budget-subentry #f 8 1 'gnc:budget-day + (make-recurring-mechanism))) #t) + (make-budget-entry + "gifts" '("Expense:Gifts") #f + (list + (make-budget-subentry #f 400 1 'gnc:budget-year + (make-recurring-mechanism)) + (make-budget-subentry "xmas" 400 1 'gnc:budget-year + (make-bill-mechanism -30 -5))) #t) + (make-budget-entry + "rent" '("Expense:Household:Rent") #f + (list + (make-budget-subentry #f 312.50 1 'gnc:budget-month + (make-bill-mechanism 1 2))) #t) + (make-budget-entry + "house junk" '("Expense:Household:Stuff") #f + (list + (make-budget-subentry #f 25 1 'gnc:budget-month + (make-recurring-mechanism))) #t) + (make-budget-entry + "medical" '("Expense:Medical:Dental" + "Expense:Medical:Optical" + "Expense:Medical:Other") #f + (list + (make-budget-subentry #f 1000 1 'gnc:budget-year + (make-contingency-mechanism))) #t) + (make-budget-entry + "clothes" '("Expense:Personal:Clothes") #f + (list + (make-budget-subentry #f 150 3 'gnc:budget-month + (make-recurring-mechanism))) #t) + (make-budget-entry + "hygeine" '("Expense:Personal:Personal maintenance") #f + (list + (make-budget-subentry #f 30 1 'gnc:budget-month + (make-recurring-mechanism))) #t) + (make-budget-entry + "newspapers" '("Expense:Stuff:Newspapers") #f + (list + (make-budget-subentry #f 20.52 1 'gnc:budget-month + (make-bill-mechanism 14 14))) #t) + (make-budget-entry "stuff" '("Expense:Stuff:CD's" + "Expense:Stuff:Electronic entertainment" + "Expense:Stuff:Fiction" + "Expense:Stuff:Games" + "Expense:Stuff:Magazines" + "Expense:Stuff:Musical Equipment" + "Expense:Stuff:Software" + "Expense:Stuff:Sports equipment" + "Expense:Stuff:Videos") #f + (list + (make-budget-subentry #f 250 1 'gnc:budget-month + (make-recurring-mechanism))) #t) + (make-budget-entry + "student loan" '("Expense:Bills:Student Loan Interest" + "Loans:student loan") #f + (list + (make-budget-subentry #f 94.54 1 'gnc:budget-month + (make-bill-mechanism -1 -1))) #t) + (make-budget-entry + "car loan" '("Expense:Car:Loan Interest" + "Loans:Car Loan") #f + (list + (make-budget-subentry #f 374.18 1 'gnc:budget-month + (make-bill-mechanism 15 17))) #t) + (make-budget-entry + "RRSP loan" '("Expense:Investment Expenses:RRSP LOC Interest" + "Loans:Scotia Bank RRSP Line of Credit") + budget-filter-pred-debit + (list + (make-budget-subentry #f 100 1 'gnc:budget-month + (make-bill-mechanism 5 8))) #t) + (make-budget-entry + "cash write off" '("Expense:Cash write-off") #f + (list + (make-budget-subentry #f 60 1 'gnc:budget-month + (make-recurring-mechanism))) #t) + (make-budget-entry + "taxes" '("Expense:Taxes:CPP" "Expense:Taxes:EI" + "Expense:Taxes:Federal Income Tax") #f + (list + (make-budget-subentry #f 1034.38 1 'gnc:budget-month + (make-bill-mechanism -1 -2))) #t))) ;; these are the "other collectors". This is where all transactions @@ -182,30 +298,39 @@ ;; by account-type, which is an integer. (define gnc:budget-others (list - (make-budget-entry "other bank" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) #f) - (make-budget-entry "other cash" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) #f) - (make-budget-entry "other asset" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) #f) - (make-budget-entry "other credit" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) #f) - (make-budget-entry "other liability" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) #f) - (make-budget-entry "other stock" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) #f) - (make-budget-entry "other mutual" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) #f) - (make-budget-entry "other currency" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) #f) - (make-budget-entry "other income" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) - 'gnc:budget-comment) - (make-budget-entry "other expense" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) - 'gnc:budget-comment) - (make-budget-entry "other equity" '() (list - (make-budget-subentry #f 0 1 'gnc:budget-month (make-nominal-mechanism))) #f))) + (make-budget-entry "other bank" '() #f (list + (make-budget-subentry #f 0 1 'gnc:budget-month + (make-nominal-mechanism))) #f) + (make-budget-entry "other cash" '() #f (list + (make-budget-subentry #f 0 1 'gnc:budget-month + (make-nominal-mechanism))) #f) + (make-budget-entry "other asset" '() #f (list + (make-budget-subentry #f 0 1 'gnc:budget-month + (make-nominal-mechanism))) #f) + (make-budget-entry "other credit" '() #f (list + (make-budget-subentry #f 0 1 'gnc:budget-month + (make-nominal-mechanism))) #f) + (make-budget-entry "other liability" '() #f (list + (make-budget-subentry #f 0 1 'gnc:budget-month + (make-nominal-mechanism))) #f) + (make-budget-entry "other stock" '() #f (list + (make-budget-subentry #f 0 1 'gnc:budget-month + (make-nominal-mechanism))) #f) + (make-budget-entry "other mutual" '() #f (list + (make-budget-subentry #f 0 1 'gnc:budget-month + (make-nominal-mechanism))) #f) + (make-budget-entry "other currency" '() #f (list + (make-budget-subentry #f 0 1 'gnc:budget-month + (make-nominal-mechanism))) #f) + (make-budget-entry "other income" '() #f (list + (make-budget-subentry #f -10000 5 'gnc:budget-year + (make-contingency-mechanism))) 'gnc:budget-comment) + (make-budget-entry "other expense" '() #f (list + (make-budget-subentry #f 10000 5 'gnc:budget-year + (make-contingency-mechanism))) 'gnc:budget-comment) + (make-budget-entry "other equity" '() #f (list + (make-budget-subentry #f 10000 5 'gnc:budget-year + (make-contingency-mechanism))) #f))) (define budget-entry-get-description (record-accessor budget-entry-structure 'description)) @@ -222,6 +347,9 @@ (define budget-entry-get-action (record-accessor budget-entry-structure 'action)) +(define budget-entry-get-filter-pred + (record-accessor budget-entry-structure 'filter-pred)) + (define budget-subentry-get-amount (record-accessor budget-subentry-structure 'amount)) @@ -344,7 +472,8 @@ (define (budget-report-accumulate-actual! value budget-line) (budget-report-set-actual! (budget-line-get-report budget-line) - (+ value (budget-report-get-actual (budget-line-get-report budget-line))))) + (+ value (budget-report-get-actual + (budget-line-get-report budget-line))))) (define budget-subreport-set-min-expected! (record-modifier budget-subreport-structure 'minimum-expected)) @@ -402,7 +531,7 @@ ((budget-nominal-pred mechanism) (budget-calculate-nominal-subreport! subentry subreport mechanism begin-date end-date)) - (else (gnc:debug "invalid mechanism!"))) + (else (gnc:error "invalid mechanism!"))) (budget-report-accumulate-min-expected! report (budget-subreport-get-minimum-expected subreport)) (budget-report-accumulate-max-expected! @@ -444,7 +573,9 @@ (let ((np (budget-num-periods subentry begin end)) (amount (budget-subentry-get-amount subentry))) (let ((min - (max 0 (* (- np 1.0) amount)))) + (if (>= amount 0) + (max 0 (* (- np 1.0) amount)) + (min 0 (* (- np 1.0) amount))))) (budget-subreport-set-min-expected! subreport min) (budget-subreport-set-max-expected! subreport (+ min amount))))) @@ -529,45 +660,63 @@ (define (budget-calculate-actual! budget-hash others begin-date-secs end-date-secs) (let loop ((group (gnc:get-current-group))) - (cond ((not (pointer-token-null? group)) - (gnc:group-map-accounts - (lambda (account) - (let* ((line - (budget-get-line-hash - budget-hash - (gnc:account-get-full-name account))) - (line2 (cond (line line) - (else - (vector-ref others (gnc:account-get-type account))))) - (acc 0)) - (budget-report-set-account-type! (budget-line-get-report line2) - (gnc:account-get-type account)) - (cond ((budget-entry-get-action (budget-line-get-entry line2)) - (set! acc 0) - (gnc:for-each-split-in-account - account - (lambda (split) - (let ((date - (car (gnc:transaction-get-date-posted - (gnc:split-get-parent split))))) - (if (and (>= date begin-date-secs) - (<= date end-date-secs)) - (set! acc (+ acc (gnc:split-get-value split))))))) - (budget-report-accumulate-actual! acc line2))) - (loop (gnc:account-get-children account)))) - group))))) + (cond + ((not (pointer-token-null? group)) + (gnc:group-map-accounts + (lambda (account) + (let* ((line + (budget-get-line-hash budget-hash (gnc:account-get-full-name account))) + (line2 (cond (line line) + (else + (vector-ref others (gnc:account-get-type account))))) + (acc 0) + (filter-pred (budget-entry-get-filter-pred + (budget-line-get-entry line2)))) + (budget-report-set-account-type! (budget-line-get-report line2) + (gnc:account-get-type account)) + (cond + ((budget-entry-get-action (budget-line-get-entry line2)) + (set! acc 0) + (gnc:for-each-split-in-account + account + (lambda (split) + (let ((date + (car (gnc:timepair-canonical-day-time + (gnc:transaction-get-date-posted + (gnc:split-get-parent split)))))) + (cond + ((and (>= date begin-date-secs) + (<= date end-date-secs)) + (cond + ((not line) + (gnc:debug (list + (gnc:account-get-full-name account) + (gnc:split-get-value split))))) + (cond + (filter-pred + (cond + ((filter-pred split line2) + (set! acc (+ acc (gnc:split-get-value split)))))) + (else + (set! acc (+ acc (gnc:split-get-value split)))))))))) + (budget-report-accumulate-actual! acc line2))) + (loop (gnc:account-get-children account)))) + group))))) (define (budget-calculate-delta! line) (let ((entry (budget-line-get-entry line)) (report (budget-line-get-report line))) - (let ((min (budget-report-get-minimum-expected report)) - (max (budget-report-get-maximum-expected report)) + (let ((minimum (budget-report-get-minimum-expected report)) + (maximum (budget-report-get-maximum-expected report)) (actual (budget-report-get-actual report))) - (budget-report-set-delta! - report - (cond ((<= actual min) (- min actual)) - ((>= actual max) (- max actual)) - (else 0.0)))))) + ;; note: for income, min > max, so swap if necessary + (let ((mn (min minimum maximum)) + (mx (max minimum maximum))) + (budget-report-set-delta! + report + (cond ((<= actual mn) (- mn actual)) + ((>= actual mx) (- mx actual)) + (else 0.0))))))) ;;; Hash search (define budget-get-line-hash @@ -614,7 +763,7 @@ (gnc:make-multichoice-option "Report Options" "View" "c" "Type of budget report" - 'full + 'status (list #(full "Full" "Show all columns") @@ -632,7 +781,7 @@ ((gnc:budget-week) (gnc:date-to-week-fraction caltime)) ((gnc:budget-month) (gnc:date-to-month-fraction caltime)) ((gnc:budget-year) (gnc:date-to-year-fraction caltime)) - (else (gnc:debug "undefined period type in budget!") #f))) + (else (gnc:error "undefined period type in budget!") #f))) (define (gnc:date-N-delta caltime1 caltime2 type) (case type @@ -646,7 +795,7 @@ (- (gnc:date-to-month-fraction caltime2) (gnc:date-to-month-fraction caltime1))) ((gnc:budget-year) (gnc:date-year-delta caltime1 caltime2)) - (else (gnc:debug "undefined period type in budget!") #f))) + (else (gnc:error "undefined period type in budget!") #f))) ;; returns the "day number" of the specified period. For example, ;; December 31 is day #92 in a 3 month period. @@ -682,7 +831,7 @@ 0 (+ (loop (- year 1)) (gnc:days-in-year year)))))) - (else (gnc:debug "undefined period type in budget!") #f)))) + (else (gnc:error "undefined period type in budget!") #f)))) ;; describe a time type @@ -733,17 +882,17 @@ (budget-line-make-subentry-list-proc budget-subentry-get-description) (html-make-left-cell (html-make-ital html-string))) ;; fixme: accounts - (make-report-spec - "Account Type" - (budget-line-make-report-proc budget-report-get-account-type) - (html-make-left-cell - (lambda (acc) (symbol->string (gnc:account-type->symbol acc)))) - #f ; total-proc - #f ; subtotal-html-proc - #f ; total-html-proc - #t ; first-last-preference - #f ; subentry-list-proc - #f) ; subentry-html-proc +; (make-report-spec +; "Account Type" +; (budget-line-make-report-proc budget-report-get-account-type) +; (html-make-left-cell +; (lambda (acc) (symbol->string (gnc:account-type->symbol acc)))) +; #f ; total-proc +; #f ; subtotal-html-proc +; #f ; total-html-proc +; #t ; first-last-preference +; #f ; subentry-list-proc +; #f) ; subentry-html-proc (make-report-spec "Amount" #f ; get-value-proc @@ -828,6 +977,21 @@ #f) ; subentry-html-proc )) +(define gnc:budget-full-report-sort-specs + (list + (make-report-sort-spec + (budget-line-make-report-proc budget-report-get-account-type) + < + = + = + (lambda (acc) (symbol->string (gnc:account-type->symbol acc)))) + (make-report-sort-spec + (budget-line-make-report-proc budget-report-get-actual) + < + = + #f + #f))) + (define gnc:budget-balance-report-specs (list (make-report-spec @@ -884,6 +1048,21 @@ (html-make-right-cell (html-make-ital html-currency))) )) +(define gnc:budget-balance-report-sort-specs + (list + (make-report-sort-spec + (budget-line-make-report-proc budget-report-get-account-type) + < + = + = + (lambda (acc) (symbol->string (gnc:account-type->symbol acc)))) + (make-report-sort-spec + (budget-line-make-report-proc budget-report-get-nominal) + < + = + #f + #f))) + (define gnc:budget-status-report-specs (list (make-report-spec @@ -938,6 +1117,21 @@ #f) ; subentry-html-proc )) +(define gnc:budget-status-report-sort-specs + (list + (make-report-sort-spec + (budget-line-make-report-proc budget-report-get-account-type) + < + = + = + (lambda (acc) (symbol->string (gnc:account-type->symbol acc)))) + (make-report-sort-spec + (budget-line-make-report-proc budget-report-get-delta) + < + = + #f + #f))) + (define (gnc:budget-renderer options) (let* ((begindate (gnc:lookup-option options "Report Options" "From")) (enddate (gnc:lookup-option options "Report Options" "To")) @@ -993,8 +1187,11 @@ (html-para "This is the full debug report. It is mainly useful for debugging the budget report.") (html-start-table) (html-table-headers gnc:budget-full-report-specs) - (html-table-entries-first budget-list gnc:budget-full-report-specs - budget-line-get-false-subentries) + (html-table-render-entries budget-list + gnc:budget-full-report-specs + gnc:budget-full-report-sort-specs + html-table-entry-render-entries-first + budget-line-get-false-subentries) (html-table-totals budget-list gnc:budget-full-report-specs) (html-end-table) (html-end-document))) @@ -1005,8 +1202,11 @@ (html-para "This is the balancing view. It is supposed to be useful when you are balancing your budget.") (html-start-table) (html-table-headers gnc:budget-balance-report-specs) - (html-table-subentries-merged budget-list gnc:budget-balance-report-specs - budget-line-get-false-subentries) + (html-table-render-entries budget-list + gnc:budget-balance-report-specs + gnc:budget-balance-report-sort-specs + html-table-entry-render-subentries-merged + budget-line-get-false-subentries) (html-table-totals budget-list gnc:budget-balance-report-specs) (html-end-table) (html-end-document))) @@ -1017,8 +1217,11 @@ (html-para "This is the status view. It is supposed to tell you the current status of your budget.") (html-start-table) (html-table-headers gnc:budget-status-report-specs) - (html-table-entries-only budget-list gnc:budget-status-report-specs - budget-line-get-false-subentries) + (html-table-render-entries budget-list + gnc:budget-status-report-specs + gnc:budget-status-report-sort-specs + html-table-entry-render-entries-only + budget-line-get-false-subentries) (html-table-totals budget-list gnc:budget-status-report-specs) (html-end-table) (html-end-document)))))) diff --git a/src/scm/report/report-list.scm b/src/scm/report/report-list.scm index 4f0e6652a0..4eccc3c82f 100644 --- a/src/scm/report/report-list.scm +++ b/src/scm/report/report-list.scm @@ -7,4 +7,5 @@ (gnc:depend "report/hello-world.scm") (gnc:depend "report/transaction-report.scm") (gnc:depend "report/budget-report.scm") +(gnc:depend "report/transaction-report-2.scm") diff --git a/src/scm/report/transaction-report-2.scm b/src/scm/report/transaction-report-2.scm new file mode 100644 index 0000000000..d43d567d6a --- /dev/null +++ b/src/scm/report/transaction-report-2.scm @@ -0,0 +1,295 @@ +;; -*-scheme-*- +;; transaction-report.scm +;; Report on all transactions in an account +;; Robert Merkel (rgmerk@mira.net) + +(gnc:support "report/transaction-report.scm") +(gnc:depend "report-utilities.scm") +(gnc:depend "date-utilities.scm") +(gnc:depend "html-generator.scm") + +(let () + + (define (trans-report-make-split-parent-proc parent-proc) + (lambda (split) + (parent-proc (gnc:split-get-parent split)))) + + ;; given a split, find the account-full-name from the other split. + ;; not useful when there is more than one split in a transaction + (define (split-get-other-account-full-name split) + (gnc:account-get-full-name + (gnc:split-get-account + (let ((trans (gnc:split-get-parent split))) + (let ((split0 (gnc:transaction-get-split trans 0)) + (split1 (gnc:transaction-get-split trans 1))) + (if (equal? split0 split) split1 split0)))))) + + (define trans-report-specs + (list + (make-report-spec + "Date" + (trans-report-make-split-parent-proc gnc:transaction-get-date-posted) + (html-make-left-cell + (lambda (date) (html-string (gnc:print-date date)))) + #f ; total-proc + #f ; subtotal-html-proc + #f ; total-html-proc + #t ; first-last-preference + #f ; subs-list-proc + #f) ; subentry-html-proc + (make-report-spec + "Num" + (trans-report-make-split-parent-proc gnc:transaction-get-num) + (html-make-left-cell html-string) + #f ; total-proc + #f ; subtotal-html-proc + #f ; total-html-proc + #t ; first-last-preference + #f ; subs-list-proc + #f) ; subentry-html-proc + (make-report-spec + "Description" + (trans-report-make-split-parent-proc gnc:transaction-get-description) + (html-make-left-cell html-string) + #f ; total-proc + #f ; subtotal-html-proc + #f ; total-html-proc + #t ; first-last-preference + #f ; subs-list-proc + #f) ; subentry-html-proc + (make-report-spec + "Memo" + gnc:split-get-memo + (html-make-left-cell html-string) + #f ; total-proc + #f ; subtotal-html-proc + #f ; total-html-proc + #t ; first-last-preference + #f ; subs-list-proc + #f) ; subentry-html-proc + (make-report-spec + "Account" + split-get-other-account-full-name + (html-make-left-cell html-string) + #f ; total-proc + #f ; subtotal-html-proc + #f ; total-html-proc + #t ; first-last-preference + #f ; subs-list-proc + #f) ; subentry-html-proc + (make-report-spec + "Amount" + gnc:split-get-value + (html-make-right-cell html-currency) + + ; total-proc + (html-make-right-cell (html-make-strong html-currency)) + (html-make-right-cell (html-make-strong html-currency)) + #t ; first-last-preference + #f ; subentry-list-proc + #f))) ; subentry-html-proc + + (define trans-report-sort-specs + (list + (make-report-sort-spec + (lambda (split) (gnc:account-get-full-name (gnc:split-get-account split))) + string-ci= date begin-date-secs) + (<= date end-date-secs))))) + + ;; register a configuration option for the transaction report + (define (trep-options-generator) + (define gnc:*transaction-report-options* (gnc:new-options)) + (define (gnc:register-trep-option new-option) + (gnc:register-option gnc:*transaction-report-options* new-option)) + ;; from date + ;; hack alert - could somebody set this to an appropriate date? + (gnc:register-trep-option + (gnc:make-date-option + "Report Options" "From" + "a" "Report Items from this date" + (lambda () + (let ((bdtime (localtime (current-time)))) + (set-tm:sec bdtime 0) + (set-tm:min bdtime 0) + (set-tm:hour bdtime 0) + (set-tm:mday bdtime 1) + (set-tm:mon bdtime 0) + (let ((time (car (mktime bdtime)))) + (cons time 0)))) + #f)) + ;; to-date + (gnc:register-trep-option + (gnc:make-date-option + "Report Options" "To" + "b" "Report items up to and including this date" + (lambda () (cons (current-time) 0)) + #f)) + + ;; account to do report on + (gnc:register-trep-option + (gnc:make-account-list-option + "Report Options" "Account" + "c" "Do transaction report on these accounts" + (lambda () + (let ((current-accounts (gnc:get-current-accounts)) + (num-accounts (gnc:group-get-num-accounts + (gnc:get-current-group))) + (first-account (gnc:group-get-account + (gnc:get-current-group) 0))) + (cond ((not (null? current-accounts)) (list (car current-accounts))) + ((> num-accounts 0) (list first-account)) + (else ())))) + #f #t)) + + ;; primary sorting criterion + (gnc:register-trep-option + (gnc:make-multichoice-option + "Sorting" "Primary Key" + "a" "Sort by this criterion first" + 'date + (list #(date + "Date" + "Sort by date") + #(time + "Time" + "Sort by EXACT entry time") + #(corresponding-acc + "Transfer from/to" + "Sort by account transferred from/to's name") + #(amount + "Amount" + "Sort by amount") + #(description + "Description" + "Sort by description") + #(number + "Number" + "Sort by check/transaction number") + #(memo + "Memo" + "Sort by memo")))) + + (gnc:register-trep-option + (gnc:make-multichoice-option + "Sorting" "Primary Sort Order" + "b" "Order of primary sorting" + 'ascend + (list + #(ascend "Ascending" "smallest to largest, earliest to latest") + #(descend "Descending" "largest to smallest, latest to earliest")))) + + (gnc:register-trep-option + (gnc:make-multichoice-option + "Sorting" "Secondary Key" + "c" + "Sort by this criterion second" + 'corresponding-acc + (list #(date + "Date" + "Sort by date") + #(time + "Time" + "Sort by EXACT entry time") + #(corresponding-acc + "Transfer from/to" + "Sort by account transferred from/to's name") + #(amount + "Amount" + "Sort by amount") + #(description + "Description" + "Sort by description") + #(number + "Number" + "Sort by check/transaction number") + #(memo + "Memo" + "Sort by memo")))) + + (gnc:register-trep-option + (gnc:make-multichoice-option + "Sorting" "Secondary Sort Order" + "d" "Order of Secondary sorting" + 'ascend + (list + #(ascend "Ascending" "smallest to largest, earliest to latest") + #(descend "Descending" "largest to smallest, latest to earliest")))) + + gnc:*transaction-report-options*) + + (define string-db (gnc:make-string-database)) + + (define (gnc:titles) + (map (lambda (key) (string-append "" (string-db 'lookup key) "")) + (list 'date 'num 'desc 'memo 'category 'credit 'debit 'balance))) + + (define (gnc:trep-renderer options) + (let* ((begindate (gnc:lookup-option options "Report Options" "From")) + (enddate (gnc:lookup-option options "Report Options" "To")) + (tr-report-account-op (gnc:lookup-option + options "Report Options" "Account")) + (tr-report-primary-key-op (gnc:lookup-option options + "Sorting" + "Primary Key")) + (tr-report-primary-order-op (gnc:lookup-option + options "Sorting" + "Primary Sort Order")) + (tr-report-secondary-key-op (gnc:lookup-option options + "Sorting" + "Secondary Key")) + (tr-report-secondary-order-op + (gnc:lookup-option options "Sorting" "Secondary Sort Order")) + (accounts (gnc:option-value tr-report-account-op)) + (date-filter-pred (gnc:tr-report-make-date-filter-predicate + (car (gnc:option-value begindate)) + (car (gnc:option-value enddate)))) + (split-list + (apply + append + (map + (lambda (account) + (make-split-list account date-filter-pred)) + accounts)))) + (gnc:debug split-list) + (list + (html-start-document-title "Transaction Report") + (html-para "Transaction report using the new reporting framework in html-generator.scm") + (html-start-table) + (html-table-headers trans-report-specs) + (html-table-render-entries split-list + trans-report-specs + trans-report-sort-specs + html-table-entry-render-entries-only + #f) + (html-table-totals split-list trans-report-specs) + (html-end-table) + (html-end-document)))) + + (gnc:define-report + 'version 1 + 'name "Transactions 2" + 'options-generator trep-options-generator + 'renderer gnc:trep-renderer))