diff --git a/src/engine/util.c b/src/engine/util.c index 4add53e0e1..68a4ad1ac0 100644 --- a/src/engine/util.c +++ b/src/engine/util.c @@ -479,7 +479,7 @@ xaccSPrintAmount (char * bufp, double val, short shrs) GNC_T, min_trailing_zeros); } -char * +char * xaccPrintAmount (double val, short shrs) { /* hack alert -- this is not thread safe ... */ @@ -491,6 +491,19 @@ xaccPrintAmount (double val, short shrs) return buf; } +char * +xaccPrintAmountArgs (double val, gncBoolean print_currency_symbol, + gncBoolean print_separators, gncBoolean is_shares_value) +{ + short shrs = 0; + + if (print_currency_symbol) shrs |= PRTSYM; + if (print_separators) shrs |= PRTSEP; + if (is_shares_value) shrs |= PRTSHR; + + return xaccPrintAmount(val, shrs); +} + /********************************************************************\ * xaccParseAmount * diff --git a/src/engine/util.h b/src/engine/util.h index fdf1bb9726..4b1e45ec11 100644 --- a/src/engine/util.h +++ b/src/engine/util.h @@ -151,7 +151,7 @@ struct lconv * gnc_localeconv(); * * PRTSYM -- also print currency symbol. * PRTSHR -- print four decimal places - * PRTSYM | PRTSHR -- prints three decimal places followed by string "shrs" + * PRTSYM | PRTSHR -- prints three decimal places followed by string "shrs" * PRTSEP -- print comma-separated K's * * The xaccPrintAmount() routine returns a pointer to a statically @@ -165,6 +165,10 @@ struct lconv * gnc_localeconv(); * number of trailing zeros to be set. You can also set * whether the amount should be printed as monetary or * non-monetary, which affects fomatting in locales. + * + * The xaccPrintAmountArgs() routine is identical to xaccPrintAmount, + * except that the arguments are given as boolean values intead of + * a bitfield. This is primarily intended for guile use. */ #define PRTSYM 0x1 @@ -176,6 +180,10 @@ int xaccSPrintAmount (char *buf, double val, short shrs); int xaccSPrintAmountGeneral (char * bufp, double val, short shrs, int precision, gncBoolean monetary, int min_trailing_zeros); +char * xaccPrintAmountArgs (double val, + gncBoolean print_currency_symbol, + gncBoolean print_separators, + gncBoolean is_shares_value); /* Parse i18n amount strings */ double xaccParseAmount (const char * instr, gncBoolean monetary); @@ -188,7 +196,7 @@ double xaccParseAmount (const char * instr, gncBoolean monetary); * or they may be in european format: DDD.DDD.DDD,CC * The routine tries to 'guess' which of these it is. * This sounds really dopey, but Intuit/Quicken managed to 'internationalize' - * thier export format, causeing no end of pain. + * their export format, causing no end of pain. * * XXX hack alert: the right way to do this is to do the following: * -- have a global flag that indicates 'euro' or 'us style' diff --git a/src/scm/date-utilities.scm b/src/scm/date-utilities.scm index b62181264e..d751782819 100644 --- a/src/scm/date-utilities.scm +++ b/src/scm/date-utilities.scm @@ -65,23 +65,6 @@ (define (gnc:date-to-day-fraction caltime) (/ (/ caltime 3600.0) 24)) -;; convert a date to a defined fraction -(define (gnc:date-to-N-fraction caltime type) - (case type - ((gnc:budget-day) (gnc:date-to-day-fraction caltime)) - ((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))) - -;; describe a time type -(define (gnc:date-describe-type type) - (case type - ((gnc:budget-day) "days") - ((gnc:budget-week) "weeks") - ((gnc:budget-month) "months") - ((gnc:budget-year) "years"))) - ;; Modify a date (define (moddate op adate delta) (let ((newtm (localtime (car adate)))) diff --git a/src/scm/report-utilities.scm b/src/scm/report-utilities.scm index 7490d609e2..d3020bee02 100644 --- a/src/scm/report-utilities.scm +++ b/src/scm/report-utilities.scm @@ -2,6 +2,9 @@ ;;; Reporting utilities (gnc:support "report-utilities.scm") +(define (gnc:amount->formatted-string amount shares_value?) + (gnc:amount->string amount #t #t shares_value?)) + (define (gnc:account-separator-char) (let ((option (gnc:lookup-option gnc:*options-entries* "General" "Account Separator"))) @@ -18,47 +21,53 @@ ;; get a full account name (define (gnc:account-get-full-name account) (let ((separator (gnc:account-separator-char))) - (cond ((pointer-token-null? account) "") - (else - (let ((parent-name - (gnc:account-get-full-name - (gnc:group-get-parent - (gnc:account-get-parent account))))) - (if (string=? parent-name "") - (gnc:account-get-name account) - (string-append - parent-name - separator - (gnc:account-get-name account)))))))) + (if (pointer-token-null? account) + "" + (let ((parent-name + (gnc:account-get-full-name + (gnc:group-get-parent + (gnc:account-get-parent account))))) + (if (string=? parent-name "") + (gnc:account-get-name account) + (string-append + parent-name + separator + (gnc:account-get-name account))))))) (define (gnc:filter-list the-list predicate) - (cond ((not (list? the-list)) - (gnc:error("Attempted to filter a non-list object"))) - ((null? the-list) '()) - ((predicate (car the-list)) - (cons (car the-list) - (gnc:filter-list (cdr the-list) predicate))) - (else (gnc:filter-list (cdr the-list) predicate)))) + (cond + ((not (list? the-list)) + (gnc:error("Attempted to filter a non-list object"))) + ((null? the-list) + '()) + ((predicate (car the-list)) + (cons (car the-list) + (gnc:filter-list (cdr the-list) predicate))) + (else (gnc:filter-list (cdr the-list) predicate)))) ;; like map, but restricted to one dimension, and ;; guaranteed to have inorder semantics. (define (gnc:inorder-map the-list fn) - (cond ((not (list? the-list)) - (gnc:error("Attempted to map a non-list object"))) - ((not (procedure? fn)) - (gnc:error("Attempted to map a non-function object to a list"))) - ((eq? the-list '()) '()) - (else (cons (fn (car the-list)) - (gnc:inorder-map (cdr the-list) fn))))) + (cond + ((not (list? the-list)) + (gnc:error("Attempted to map a non-list object"))) + ((not (procedure? fn)) + (gnc:error("Attempted to map a non-function object to a list"))) + ((eq? the-list '()) '()) + (else (cons (fn (car the-list)) + (gnc:inorder-map (cdr the-list) fn))))) (define (gnc:for-loop thunk first last step) - (cond ((< first last) (thunk first) - (gnc:for-loop thunk (+ first step) last step)) - (else #f))) + (if (< first last) + (begin + (thunk first) + (gnc:for-loop thunk (+ first step) last step)) + #f)) ;;; 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))) + (gnc:for-loop (lambda (x) + (thunk (gnc:account-get-split account x))) 0 (gnc:account-get-split-count account) 1)) (define (gnc:group-map-accounts thunk group) @@ -73,7 +82,7 @@ ; (define (gnc:account-transactions-for-each thunk account) ; ;; You must call gnc:group-reset-write-flags on the account group ; ;; before using this... - +; ; (let loop ((num-splits (gnc:account-get-split-count account)) ; (i 0)) ; (if (< i num-splits) @@ -95,12 +104,52 @@ (loop num-splits (+ i 1))) '()))) +;;; Here's a statistics collector... Collects max, min, total, and makes +;;; it easy to get at the mean. + +;;; 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) + (let ;;; values + ((value 0) + (totalitems 0) + (max -10E9) + (min 10E9)) + (let ;;; Functions to manipulate values + ((adder (lambda (amount) + (if (number? amount) + (begin + (set! value (+ amount value)) + (if (> amount max) + (set! max amount)) + (if (< amount min) + (set! min amount)) + (set! totalitems (+ 1 totalitems)))))) + (gettotal (lambda () value)) + (getaverage (lambda () (/ value totalitems))) + (getmax (lambda () max)) + (getmin (lambda () min)) + (reset-all (lambda () + (set! value 0) + (set! max -10E9) + (set! min 10E9) + (set! totalitems 0)))) + (lambda (action value) ;;; Dispatch function + (case action + ('add (adder value)) + ('total (gettotal)) + ('average (getaverage)) + ('getmax (getmax)) + ('getmin (getmin)) + ('reset (reset-all))))))) + (define (makedrcr-collector) - (let + (let ;;; values ((debits 0) (credits 0) (totalitems 0)) - (let + (let ;;; Functions to manipulate values ((adder (lambda (amount) (if (> 0 amount) (set! credits (- credits amount)) @@ -115,7 +164,7 @@ (set! credits 0) (set! debits 0) (set! totalitems 0)))) - (lambda (action value) + (lambda (action value) ;;; Dispatch function (case action ('add (adder value)) ('debits (getdebits)) @@ -131,17 +180,17 @@ lst ; found, quit search and don't add again (cons (car lst) (addunique (cdr lst) x))))) ; keep searching - ;; find's biggest number in recursive set of vectors (define (find-largest-in-vector input) (let loop ((i 0) - (max 0)) ; fixme: should be most negative number - (if (= i (vector-length input)) max + (max -9999999)) ; fixme: should be most negative number + (if (= i (vector-length input)) + max (let subloop ((x (vector-ref input i))) - (cond ((vector? x) (subloop (find-largest-in-vector x))) + (cond ((vector? x) + (subloop (find-largest-in-vector x))) ((number? x) (if (> x max) (loop (+ i 1) x) (loop (+ i 1) max))) (else (loop (+ i 1) max))))))) - ;; takes in a vector consisting of integers, #f's and vectors (which ;; take integers, #f's and vectors ...) @@ -151,50 +200,54 @@ ;; #(1 #(0 #f 2) 3) -> #( (1 0) (0) (1 2) (2) ) (define (find-vector-mappings input) - (let ((outvec (make-vector (+ 1 (find-largest-in-vector input)) #f))) + (let + ((outvec (make-vector (+ 1 (find-largest-in-vector input)) #f))) (let loop ((i 0) (refs '()) (vec input)) - (cond ((= i (vector-length vec)) outvec) - (else - (let ((item (vector-ref vec i))) - (if (vector? item) (loop 0 (cons i refs) item)) - (if (integer? item) - (if (>= item 0) - (vector-set! outvec item (reverse (cons i refs))))) - (loop (+ i 1) refs vec))))) + (if (= i (vector-length vec)) + outvec + (let ((item (vector-ref vec i))) + (if (vector? item) (loop 0 (cons i refs) item)) + (if (integer? item) + (if (>= item 0) + (vector-set! outvec item (reverse (cons i refs))))) + (loop (+ i 1) refs vec)))) outvec)) ;; recursively apply vector-ref (define (vector-N-ref vector ref-list) - (cond ((eqv? ref-list '()) vector) - (else (vector-N-ref (vector-ref vector (car ref-list)) (cdr ref-list))))) + (if (eqv? ref-list '()) + vector + (vector-N-ref (vector-ref vector (car ref-list)) (cdr ref-list)))) ;; map's a recursive vector in a given order (returning a list). the ;; order is as generated by find-vector-mappings. (define (vector-map-in-specified-order proc vector order) (let loop ((i 0)) - (cond ((= i (vector-length order)) '()) - (else - (let ((ref-list (vector-ref order i))) - (cond ((not ref-list) (loop (+ 1 i))) - (else - (cons (proc (vector-N-ref vector ref-list)) - (loop (+ 1 i)))))))))) + (if (= i (vector-length order)) + '() + (let + ((ref-list (vector-ref order i))) + (if (not ref-list) + (loop (+ 1 i)) + (cons (proc (vector-N-ref vector ref-list)) + (loop (+ 1 i)))))))) ;; map's a recursive vector in a given order (returning a list). the ;; order is as generated by find-vector-mappings. the procedure is a ;; vector itself, with the same structure as the input vector. (define (vector-map-in-specified-order-uniquely procvec vector order) (let loop ((i 0)) - (cond ((= i (vector-length order)) '()) - (else - (let ((ref-list (vector-ref order i))) - (cond ((not ref-list) (loop (+ 1 i))) - (else - (cons ((vector-N-ref procvec ref-list) - (vector-N-ref vector ref-list)) - (loop (+ 1 i)))))))))) + (if (= i (vector-length order)) + '() + (let + ((ref-list (vector-ref order i))) + (if (not ref-list) + (loop (+ 1 i)) + (cons ((vector-N-ref procvec ref-list) + (vector-N-ref vector ref-list)) + (loop (+ 1 i)))))))) ;;; applies thunk to each split in account account (define (gnc:for-each-split-in-account account thunk) @@ -223,7 +276,6 @@ (let ((time (car (mktime bdtime)))) (cons time 0)))) #f)) - ;; to-date (gnc:register-trep-option (gnc:make-date-option @@ -317,6 +369,5 @@ 'ascend (list #(ascend "Ascending" "smallest to largest, earliest to latest") #(descend "Descending" "largest to smallest, latest to earliest")))) - gnc:*transaction-report-options*) diff --git a/src/scm/report/average-balance.scm b/src/scm/report/average-balance.scm index 07818ef72d..ddaf64506c 100644 --- a/src/scm/report/average-balance.scm +++ b/src/scm/report/average-balance.scm @@ -19,87 +19,86 @@ ;; Options (define (runavg-options-generator) - (define gnc:*runavg-track-options* (gnc:new-options)) - - ;; register a configuration option for the report - - (define (gnc:register-runavg-option new-option) - (gnc:register-option gnc:*runavg-track-options* new-option)) - - ;; from date - (gnc:register-runavg-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) - (cons (car (mktime bdtime)) 0))) - #f)) - - ;; to-date - (gnc:register-runavg-option - (gnc:make-date-option - "Report Options" "To" - "c" "Report items up to and including this date" - (lambda () (cons (current-time) 0)) - #f)) - - ;; account(s) to do report on - - (gnc:register-runavg-option - (gnc:make-account-list-option - "Report Options" "Account" - "d" "Do transaction report on this account" - (lambda () - (let ((current-accounts (gnc:get-current-accounts)) - (num-accounts - (gnc:group-get-num-accounts (gnc:get-current-group)))) - - (cond ((not (null? current-accounts)) current-accounts) - (else - (let ((acctlist '())) - (gnc:for-loop - (lambda(x) - (set! acctlist - (append! - acctlist - (list (gnc:group-get-account - (gnc:get-current-group) x))))) - 0 (eval num-accounts) 1) - acctlist))))) - #f #t)) - - (gnc:register-runavg-option - (gnc:make-multichoice-option - "Report Options" "Step Size" - "b" "Get number at each one of these" 'WeekDelta - (list #(DayDelta "Day" "Day") - #(WeekDelta "Week" "Week") - #(TwoWeekDelta "2Week" "Two Week") - #(MonthDelta "Month" "Month") - #(YearDelta "Year" "Year") - ))) - - (gnc:register-runavg-option - (gnc:make-simple-boolean-option - "Report Options" "Sub-Accounts" - "e" "Add in sub-accounts of each selected" #f)) - - (gnc:register-runavg-option - (gnc:make-multichoice-option - "Report Options" "Plot Type" - "f" "Get number at each one of these" 'NoPlot - (list #(NoPlot "Nothing" "Make No Plot") - #(AvgBalPlot "Average" "Average Balance") - #(GainPlot "Net Gain" "Net Gain") - #(GLPlot "Gain/Loss" "Gain And Loss")))) - - gnc:*runavg-track-options*) + (let + ((gnc:*runavg-track-options* (gnc:new-options)) + ;; register a configuration option for the report + (gnc:register-runavg-option + (lambda (new-option) + (gnc:register-option gnc:*runavg-track-options* + new-option)))) + ;; from date + (gnc:register-runavg-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) + (cons (car (mktime bdtime)) 0))) + #f)) + + ;; to-date + (gnc:register-runavg-option + (gnc:make-date-option + "Report Options" "To" + "c" "Report items up to and including this date" + (lambda () (cons (current-time) 0)) + #f)) + + ;; account(s) to do report on + + (gnc:register-runavg-option + (gnc:make-account-list-option + "Report Options" "Account" + "d" "Do transaction report on this account" + (lambda () + (let ((current-accounts (gnc:get-current-accounts)) + (num-accounts + (gnc:group-get-num-accounts (gnc:get-current-group)))) + + (cond ((not (null? current-accounts)) current-accounts) + (else + (let ((acctlist '())) + (gnc:for-loop + (lambda(x) + (set! acctlist + (append! + acctlist + (list (gnc:group-get-account + (gnc:get-current-group) x))))) + 0 num-accounts 1) + acctlist))))) + #f #t)) + + (gnc:register-runavg-option + (gnc:make-multichoice-option + "Report Options" "Step Size" + "b" "Get number at each one of these" 'WeekDelta + (list #(DayDelta "Day" "Day") + #(WeekDelta "Week" "Week") + #(TwoWeekDelta "2Week" "Two Week") + #(MonthDelta "Month" "Month") + #(YearDelta "Year" "Year") + ))) + + (gnc:register-runavg-option + (gnc:make-simple-boolean-option + "Report Options" "Sub-Accounts" + "e" "Add in sub-accounts of each selected" #f)) + + (gnc:register-runavg-option + (gnc:make-multichoice-option + "Report Options" "Plot Type" + "f" "Get number at each one of these" 'NoPlot + (list #(NoPlot "Nothing" "Make No Plot") + #(AvgBalPlot "Average" "Average Balance") + #(GainPlot "Net Gain" "Net Gain") + #(GLPlot "Gain/Loss" "Gain And Loss")))) + gnc:*runavg-track-options*)) ;; Plot strings (define AvgBalPlot "using 2:3:4:5 t 'Average Balance' with errorbars, '' using 2:3 smooth sbezier t '' with lines") @@ -171,31 +170,25 @@ (define (dl:end dl) (car (cdr dl))) (define (reduce-split-list dl tl pt av) - (let ((avgaccum 0) + (let ((stat-accumulator (make-stats-collector)) + ;;; (avgaccum 0) ;; 'add, 'total, 'average, 'getmax, 'getmin, reset + ;;; (balmin 10E9) + ;;; (balmax -10E9) + (gl-accumulator (makedrcr-collector)) (bals av) - (prevdate 0) - (balmin 10E9) - (balmax -10E9) - (gains 0) - (losses 0)) - (define (procvals) + (prevdate 0)) +;;; procvals goes away +;;; accbal runs the accumulator + (define (accbal beg end) (let ((curbal (vector-sum (car (cdr (av 'x 0)))))) - (set! balmin (min balmin curbal)) - (set! balmax (max balmax curbal)))) - - (define (accbal beg end) - (let ((curbal (vector-sum (car (cdr (av 'x 0)))))) - (set! avgaccum (+ avgaccum - (* curbal - (gnc:timepair-delta beg end)))))) - + (stat-accumulator 'add (gnc:timepair-delta beg end)))) (define (calc-in-interval d tl) (cond ((not (null? tl)) - (let* ((bd (dl:begin d)) ; begin date - (ed (dl:end d)) ; end date - (cs (car tl)) ; current split + (let* ((bd (dl:begin d)) ; begin date + (ed (dl:end d)) ; end date + (cs (car tl)) ; current split (cd (gnc:split-get-transaction-date cs)) ;current date (an (gnc:split-get-account-name cs)) ; account name (prevbal (vector-sum (car (cdr (av 'x 0)))))) @@ -211,45 +204,46 @@ (bals 'put an (gnc:split-get-balance cs)) (let ((val (gnc:split-get-value cs))) - (cond ((< 0 val) (set! gains (+ gains val))) - (else (set! losses (- losses val))))) - - (procvals) ; catch all cases + (gl-accumulator 'add val)) + (procvals) ; catch all cases (set! prevdate cd) (calc-in-interval d (cdr tl))) - (else ; Past interval, nothing to do? + (else ; Past interval, nothing to do? (accbal prevdate ed) (procvals) tl)))) - - (else ; Out of data ! + (else ; Out of data ! (accbal prevdate (dl:end d)) (procvals) tl))) - ;; Actual routine - (cond ((null? dl) '()) ;; End of recursion - (else - (let* ((bd (dl:begin (car dl))) - (ed (dl:end (car dl))) ) + ;; Actual routine + (cond ((null? dl) '());; End of recursion + (else + (let* ((bd (dl:begin (car dl))) + (ed (dl:end (car dl))) ) - ;; Reset valaccumulator values - (set! prevdate bd) - (set! avgaccum 0) - (set! gains 0) - (set! losses 0) - - (let* ((rest (calc-in-interval (car dl) tl))) - ;; list of values for report - (cons - (list - (gnc:timepair-to-ldatestring bd) - (gnc:timepair-to-ldatestring ed) - (/ avgaccum - (gnc:timepair-delta bd ed)) - balmin balmax (- gains losses) gains losses) - (reduce-split-list (cdr dl) rest pt av)))))))) + ;; Reset valaccumulator values + (set! prevdate bd) + (stat-accumulator 'reset #f) + (gl-accumulator 'reset #f) + + (let* ((rest (calc-in-interval (car dl) tl))) + ;; list of values for report + (cons + (list + (gnc:timepair-to-ldatestring bd) + (gnc:timepair-to-ldatestring ed) + (/ (stat-accumulator 'total #f) + (gnc:timepair-delta bd ed)) + (stat-accumulator 'getmin #f) + (stat-accumulator 'getmax #f) + (- (gl-accumulator 'debits #f) + (gl-accumulator 'credits #f)) + (gl-accumulator 'debits #f) + (gl-accumulator 'credits #f) + (reduce-split-list (cdr dl) rest pt av))))))))) ;; Pull a scheme list of splits from a C array (define (gnc:convert-split-list slist) @@ -333,119 +327,105 @@ (allsubaccounts (cdr accounts)))))) (define (average-balance-renderer options) - (let* ((begindate (gnc:option-value - (gnc:lookup-option options "Report Options" "From"))) - (enddate (gnc:option-value - (gnc:lookup-option options "Report Options" "To"))) - (stepsize (gnc:option-value - (gnc:lookup-option options "Report Options" "Step Size"))) - - (plotstr (gnc:option-value - (gnc:lookup-option options "Report Options" "Plot Type"))) - - (accounts (gnc:option-value - (gnc:lookup-option options - "Report Options" "Account"))) - - (dosubs (gnc:option-value - (gnc:lookup-option options - "Report Options" "Sub-Accounts"))) - - (prefix (list "" "")) - (suffix (list "" "")) - (collist - (list "Beginning" "Ending" "Average" "Max" - "Min" "Net Gain" "Gain" "Loss")) - - (report-lines '()) - (rept-data '()) - (sum-data '()) - (tempstruct '()) - (rept-text "") - (gncq (gnc:malloc-query)) - - (slist '())) - - (gnc:init-query gncq) - - (if (null? accounts) - (set! rept-text - (list "You have not selected an account.")) - (begin + (let ((gov-fun (lambda (value) + (gnc:option-value (gnc:lookup-option + options "Report Options" + value))))) + (let ((begindate (gov-fun "From")) + (enddate (gov-fun "To")) + (stepsize (gov-fun "Step Size")) + (plotstr (gov-fun "Plot Type")) + (accounts (gov-fun "Account")) + (dosubs (gov-fun "Sub-Accounts")) + (prefix (list "" "")) + (suffix (list "" "")) + (collist + (list "Beginning" "Ending" "Average" "Max" "Min" + "Net Gain" "Gain" "Loss")) + (report-lines '()) + (rept-data '()) + (sum-data '()) + (tempstruct '()) + (rept-text "") + (gncq (gnc:malloc-query)) + (slist '())) + (gnc:init-query gncq) + + (if (null? accounts) + (set! rept-text + (list "You have not selected an account.")) + (begin ; Grab account names - (set! acctname (string-join - (map gnc:account-get-name accounts) - " , ")) - (cond ((equal? dosubs #t) - (map (lambda (a) - (set! accounts (addunique accounts a))) - (allsubaccounts accounts)) + (set! acctname (string-join + (map gnc-account-getname accounts) + " , ")) + (cond ((equal? dosubs #t) + (map (lambda (a) + (set! accounts (addunique accounts a))) + (allsubaccounts accounts)) - (set! acctname (string-append acctname " and sub-accounts")))) + (set! acctname (string-append acctname " and sub-accounts")))) - (map (lambda(acct) (gnc:query-add-account gncq acct)) accounts) + (map (lambda(acct) (gnc:query-add-account gncq acct)) accounts) - (set! tempstruct - (build-mystruct-instance - (define-mystruct - (gnc:acctnames-from-list accounts)))) + (set! tempstruct + (build-mystruct-instance + (define-mystruct + (gnc:acctnames-from-list accounts)))) - (set! acctcurrency (gnc:account-get-currency (car accounts))) + (set! acctcurrency (gnc:account-get-currency (car accounts))) - (set! report-lines - (gnc:convert-split-list (gnc:query-get-splits gncq))) + (set! report-lines + (gnc:convert-split-list (gnc:query-get-splits gncq))) - (gnc:free-query gncq) + (gnc:free-query gncq) - (display (length report-lines)) - (display " Splits\n") + (display (length report-lines)) + (display " Splits\n") ; Set initial balances to zero - (map (lambda(an) (tempstruct 'put an 0)) - (gnc:acctnames-from-list accounts)) - - (dateloop begindate - enddate - (eval stepsize)) - (set! rept-data - (reduce-split-list - (dateloop begindate - enddate - (eval stepsize)) - report-lines (make-zdate) tempstruct)) - - (set! sum-data (get-averages rept-data)) - - ;; Create HTML - (set! rept-text - (html-table - collist - (append rept-data - (list "
" sum-data)))) - - ;; Do a plot - (if (not (equal? NoPlot (eval plotstr))) - (let* ((fn "/tmp/gncplot.dat") + (map (lambda(an) (tempstruct 'put an 0)) + (gnc:acctnames-from-list accounts)) + + (dateloop begindate enddate stepsize) + + (set! rept-data + (reduce-split-list + (dateloop begindate enddate stepsize) + report-lines zdate tempstruct)) + + (set! sum-data (get-averages rept-data)) + + ;; Create HTML + (set! rept-text + (html-table + collist + (append rept-data + (list "
" sum-data)))) + + ;; Do a plot + (if (not (string=? NoPlot plotstr)) + (let + ((fn "/tmp/gncplot.dat") (preplot (string-append "set xdata time\n" "set timefmt '%m/%d/%Y'\n" "set pointsize 2\n" "set title '" acctname "'\n" "set ylabel '" acctcurrency "'\n" - "set xlabel 'Period Ending'\n" - ))) - - (data-to-gpfile collist rept-data fn (eval plotstr)) - (system - (string-append "echo \"" preplot "plot '" - fn "'" (eval plotstr) - "\"|gnuplot -persist " )))))) - - (append prefix - (if (null? accounts) - () - (list "Report for " acctname "

\n")) - (list rept-text) suffix))) + "set xlabel 'Period Ending'\n"))) + + (data-to-gpfile collist rept-data fn plotstr) + (system + (string-append "echo \"" preplot "plot '" + fn "'" plotstr + "\"|gnuplot -persist " )))))) + + (append prefix + (if (null? accounts) + () + (list "Report for " acctname "

\n")) + (list rept-text) suffix)))) (gnc:define-report ;; version diff --git a/src/scm/report/balance-and-pnl.scm b/src/scm/report/balance-and-pnl.scm index aa481413d3..c96168dbc6 100644 --- a/src/scm/report/balance-and-pnl.scm +++ b/src/scm/report/balance-and-pnl.scm @@ -1,42 +1,44 @@ ;; -*-scheme-*- +;; $Id$ +;; Balance and Profit/Loss Reports (gnc:support "report/balance-and-pnl.scm") (gnc:depend "text-export.scm") +(gnc:depend "report-utilities.scm") -(let () +(let + ((l0-collector (make-stats-collector)) + (l1-collector (make-stats-collector)) + (l2-collector (make-stats-collector))) ;; Just a private scope. - (define (render-level-2-account level-2-account level-2-balance) + (define (render-level-2-account level-2-account l2-value) (let ((account-name (gnc:account-get-name level-2-account)) (type-name (gnc:account-get-type-string (gnc:account-get-type level-2-account)))) - (string-append - "" account-name "" type-name - (sprintf #f " $%10.2f\n" - level-2-balance)))) + (html-table-row + (list + account-name type-name l2-value)))) - (define (render-level-1-account account level-1-balance level-2-balance) + (define (render-level-1-account account l1-value l2-value) (let ((name (gnc:account-get-name account)) (type (gnc:account-get-type-string (gnc:account-get-type account)))) - (string-append - "" name "" type - (sprintf #f " $%10.2f" level-2-balance) - (sprintf #f "  $%10.2f \n" - level-1-balance) - "   \n"))) ;; blank line - - (define (render-total level-0-balance) - (string-append - "   \n" ;; blank line - "Net " - " " - (sprintf #f "  $%10.2f \n" - level-0-balance))) + (html-table-row + (list name type l2-value l1-value + " " " ")))) - (define (generate-balance-sheet-or-pnl report-name - report-description - balance-sheet?) + (define (render-total l0-value) + (html-table-row (list " " " " " " (html-strong "Net") + " " l0-value))) + + (define (is-it-on-balance-sheet? type balance?) + (eq? + (not (member type '(INCOME EXPENSE))) + (not balance?))) + (define (generate-balance-sheet-or-pnl report-name + report-description + balance-sheet?) ;; currency symbol that is printed is a dollar sign, for now ;; currency amounts get printed with two decimal places ;; balance sheet doesn't print income or expense @@ -46,77 +48,73 @@ ;; just translated it directly from the old ePerl with a few ;; schemifications. - (let ((level-0-balance 0) - (level-1-balance 0) - (level-2-balance 0) - (current-group (gnc:get-current-group)) - (output '())) - - (define (handle-level-2-account account) - (let ((type (gnc:account-type->symbol (gnc:account-get-type account))) - (balance (gnc:account-get-balance account))) - - (if (not balance-sheet?) (set! balance (- balance))) - - (if (not (or (and balance-sheet? - (not (eq? type 'INCOME)) - (not (eq? type 'EXPENSE))) - (and (not balance-sheet?) - (or (eq? type 'INCOME) - (eq? type 'EXPENSE))))) - ;; Ignore - '() - - ;; add in balances for any sub-sub groups - (let ((grandchildren (gnc:account-get-children account))) - - (if (not (pointer-token-null? grandchildren)) - (set! balance - ((if balance-sheet? + -) - balance (gnc:group-get-balance grandchildren)))) - - (set! level-2-balance (+ level-2-balance balance)) - (set! level-1-balance (+ level-1-balance level-2-balance)) - (let ((result (render-level-2-account account level-2-balance))) - (set! level-2-balance 0) - result))))) - - (define (handle-level-1-account account) - (let ((type (gnc:account-type->symbol (gnc:account-get-type account)))) - - (if (not (or (and balance-sheet? - (not (eq? type 'INCOME)) - (not (eq? type 'EXPENSE))) - (and (not balance-sheet?) - (or (eq? type 'INCOME) - (eq? type 'EXPENSE))))) - - ;; Ignore - '() - (let ((childrens-output (gnc:group-map-accounts - handle-level-2-account - (gnc:account-get-children account))) - (account-balance (gnc:account-get-balance account))) - - (if (not balance-sheet?) - (set! account-balance (- account-balance))) - - (set! level-2-balance (+ level-2-balance account-balance)) - (set! level-1-balance (+ level-1-balance account-balance)) - (set! level-0-balance (+ level-0-balance level-1-balance)) - - (let ((level-1-output - (render-level-1-account account - level-1-balance - level-2-balance))) - (set! level-1-balance 0) - (set! level-2-balance 0) - (list childrens-output level-1-output)))))) + (define (handle-level-1-account account) + (let ((type (gnc:account-type->symbol (gnc:account-get-type account)))) + (if (is-it-on-balance-sheet? type balance-sheet?) + ;; Ignore + '() + (let + ((childrens-output (gnc:group-map-accounts + handle-level-2-account + (gnc:account-get-children account))) + + (account-balance (gnc:account-get-balance account))) + + (if (not balance-sheet?) + (set! account-balance (- account-balance))) + (l2-collector 'add account-balance) + (l1-collector 'add account-balance) + (l0-collector 'add (l1-collector 'total #f)) + (let ((level-1-output + (render-level-1-account account + (l1-collector 'total #f) + (l2-collector 'total #f)))) + (l1-collector 'reset #f) + (l2-collector 'reset #f) + (list childrens-output level-1-output)))))) + + (define (handle-level-2-account account) + (let + ((type (gnc:account-type->symbol (gnc:account-get-type account))) + (balance (make-stats-collector)) + (rawbal (gnc:account-get-balance account))) + (balance 'add + (if balance-sheet? + rawbal + (- rawbal))) + (if (is-it-on-balance-sheet? type balance-sheet?) + ;; Ignore + '() + ;; add in balances for any sub-sub groups + (let ((grandchildren (gnc:account-get-children account))) + (if (not (pointer-token-null? grandchildren)) + (balance 'add + ((if balance-sheet? + -) + 0 + (gnc:group-get-balance grandchildren)))) + (l2-collector 'add (balance 'get #f)) + (l1-collector 'add (l2-collector 'get #f)) + (let + ((result (render-level-2-account + account (l2-collector 'get #f)))) + (l2-collector 'reset #f) + result))))) + (let + ((current-group (gnc:get-current-group)) + (output '())) + + ;;; Now, the main body + ;;; Reset all the balance collectors + (l0-collector 'reset #f) + (l1-collector 'reset #f) + (l2-collector 'reset #f) (if (not (pointer-token-null? current-group)) - (set! output - (list - (gnc:group-map-accounts handle-level-1-account current-group) - (render-total level-0-balance)))) + (set! output + (list + (gnc:group-map-accounts + handle-level-1-account + current-group) + (render-total (l0-collector 'total #f))))) (list "" @@ -130,7 +128,7 @@ "" "" - "
" (gnc:_ report-name) "
"(gnc:_ "Account Name")""(gnc:_ "Type") + "
"(gnc:_ "Account Name")"" (gnc:_ "Type") " "(gnc:_ "Balance") output @@ -141,27 +139,28 @@ (gnc:define-report - ;; version - 1 - ;; Menu name - "Balance sheet" - ;; Options Generator (none currently) - #f - ;; Code to generate the report - (lambda (options) - (generate-balance-sheet-or-pnl "Balance Sheet" - "This page shows your net worth." - #t))) - - (gnc:define-report - ;; version - 1 - ;; Menu name - "Profit and Loss" - ;; Options (none currently) - #f - ;; Code to generate the report - (lambda (options) - (generate-balance-sheet-or-pnl "Profit and Loss" - "This page shows your profits and losses." - #f)))) + ;; version + 1 + ;; Menu name + "Balance sheet" + ;; Options Generator (none currently) + #f + ;; Code to generate the report + (lambda (options) + (generate-balance-sheet-or-pnl "Balance Sheet" + "This page shows your net worth." + #t))) + + (gnc:define-report + ;; version + 1 + ;; Menu name + "Profit and Loss" + ;; Options (none currently) + #f + ;; Code to generate the report + (lambda (options) + (generate-balance-sheet-or-pnl + "Profit and Loss" + "This page shows your profits and losses." + #f)))) diff --git a/src/scm/report/budget-report.scm b/src/scm/report/budget-report.scm index fea8cec85a..5f4942a8fb 100644 --- a/src/scm/report/budget-report.scm +++ b/src/scm/report/budget-report.scm @@ -16,18 +16,36 @@ (gnc:depend "date-utilities.scm") ;; time values -(define gnc:budget-day 1) -(define gnc:budget-week 2) -(define gnc:budget-month 3) -(define gnc:budget-year 4) +;(define gnc:budget-day 1) +;(define gnc:budget-week 2) +;(define gnc:budget-month 3) +;(define gnc:budget-year 4) ;; budget types -(define gnc:budget-recurring 1) ; regular, recurring budget expenses +;(define gnc:budget-recurring 1) ; regular, recurring budget expenses ; that happen once per period -(define gnc:budget-contingency 2) ; a budget item where you estimate a +;(define gnc:budget-contingency 2) ; a budget item where you estimate a ; value over a long period for ; unexpected expenses. +;; convert a date to a defined fraction +(define (gnc:date-to-N-fraction caltime type) + (display type) (newline) + (case type + ((gnc:budget-day) (gnc:date-to-day-fraction caltime)) + ((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))) + +;; describe a time type +(define (gnc:date-describe-type type) + (case type + ((gnc:budget-day) "days") + ((gnc:budget-week) "weeks") + ((gnc:budget-month) "months") + ((gnc:budget-year) "years"))) + ;; define the budget itself. For prototype, define inline. ;; the budget is a vector of vectors. the vectors contain: ;; 0 - description: a string describing the budget line @@ -44,11 +62,11 @@ (define gnc:budget (vector (make-budget-entry "lunch" 8 '("Food:Lunch") 1 - 'gnc:budget-day gnc:budget-recurring) + 'gnc:budget-day 'gnc:budget-recurring) (make-budget-entry "junk food" 0.50 '("Food:Junk") 1 - 'gnc:budget-day gnc:budget-recurring) + 'gnc:budget-day 'gnc:budget-recurring) (make-budget-entry "car repairs" 2500 '("Car:Repairs") 5 - 'gnc:budget-year gnc:budget-contingency))) + 'gnc:budget-year 'gnc:budget-contingency))) ;;; For future: make-budget-entry should create a structure. ;;; And gnc:budget should be a list, not a vector. @@ -152,10 +170,15 @@ ;; dates are in # seconds after 1970 (define (gnc:budget-calculate-periods! budget-line budget-report-line begin-date end-date) + (display "gnc:budget-calculate-periods! ") (let* ((N-type (gnc:budget-get-period-type budget-line)) (begin-N (gnc:date-to-N-fraction begin-date N-type)) (end-N (gnc:date-to-N-fraction end-date N-type))) - (vector-set! budget-report-line 2 + (display " type:") (display N-type) + (display "begin-N:") (display begin-N) + (display " end-N:") (display end-N) (newline) + (newline) + (vector-set! budget-report-line 2 (/ (- end-N begin-N) (gnc:budget-get-period budget-line))))) @@ -182,6 +205,7 @@ ;; calculate the amount of time remaining in the budget period ;; dependency: budget-calculate-periods! (define (gnc:budget-calculate-time-remaining! budget-line budget-report-line) + (display "gnc:budget-calculate-time-remaining!") (newline) (vector-set! budget-report-line 5 (* (- (ceiling (gnc:budget-report-get-periods budget-report-line)) diff --git a/src/scm/xml-generator.scm b/src/scm/xml-generator.scm index b1cc32fd27..d9d7048b5d 100644 --- a/src/scm/xml-generator.scm +++ b/src/scm/xml-generator.scm @@ -53,10 +53,9 @@ ;;;; construct the whole document as One Big List; ;;;; output-xml-element will be useful for generating subtree output. ;;;; Your control structure will need to duplicate the structure of -;;;; output-xml-element. Alternatively, it would be a slick idea to -;;;; change output-xml-element so that "children" could be a thunk -;;;; (function with no arguments) that invokes output-xml-element -;;;; internally as needed. +;;;; output-xml-element. Alternatively, if "children" could is a thunk +;;;; (function with no arguments), invoking output-xml-element +;;;; internally as needed, the "children" can be an XML generator. (define xml-indentation 0) @@ -147,8 +146,8 @@ (cond ((not children) ;;; If children is blank (xml-display "/>" port)) ;;; Short result - ((procedure? children) ;;; children is a function - (xml-display ">" port) + ((procedure? children) ;;; If children is a function + (xml-display ">" port) (children port) ;;; Invoke the function (output-xml-element-name-end elname port)) (else