aherman
/
gnucash
mirror of https://github.com/Gnucash/gnucash
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2069 57a11ea4-9604-0410-9ed3-97b8803252fd
zzzoldreleases/1.4
Dave Peticolas 27 years ago
parent 318911182b
commit eb9bab2ef2
8 changed files with 504 additions and 447 deletions
Show Stats Download Patch File Download Diff File

15
src/engine/util.c
Unescape View File

@ -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 *

12
src/engine/util.h
Unescape View File

@ -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'

17
src/scm/date-utilities.scm
Unescape View File

@ -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))))

185
src/scm/report-utilities.scm
Unescape View File

@ -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*)

430
src/scm/report/average-balance.scm
Unescape View File

@ -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 "<HTML>" "<BODY>"))
(suffix (list "</BODY>" "</HTML>"))
(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 "<TR><TD>You have not selected an account.</TD></TR>"))
(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 "<HTML>" "<BODY>"))
(suffix (list "</BODY>" "</HTML>"))
(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 "<TR><TD>You have not selected an account.</TD></TR>"))
(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 "<TR cellspacing=0><TD><TD><TD colspan=3><HR size=2 noshade><TD colspan=3><HR size=2 noshade></TR>" 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 "<TR cellspacing=0><TD><TD><TD colspan=3><HR size=2 noshade><TD colspan=3><HR size=2 noshade></TR>" 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 "<p>\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 "<p>\n"))
(list rept-text) suffix))))
(gnc:define-report
;; version

237
src/scm/report/balance-and-pnl.scm
Unescape View File

@ -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
"<tr><td>" account-name "<td>" type-name
(sprintf #f "<td align=right nowrap>&nbsp;$%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
"<tr><td>" name "<td>" type
(sprintf #f "<td align=right nowrap>&nbsp;$%10.2f" level-2-balance)
(sprintf #f "<td align=right nowrap>&nbsp;&nbsp;<u>$%10.2f</u> \n"
level-1-balance)
"<tr><td>&nbsp;<td>&nbsp;<td>&nbsp;\n"))) ;; blank line
(define (render-total level-0-balance)
(string-append
"<tr><td>&nbsp;<td>&nbsp;<td>&nbsp;\n" ;; blank line
"<tr><td><b>Net</b><td>&nbsp;"
"<td>&nbsp;"
(sprintf #f "<td align=right nowrap>&nbsp;&nbsp;<u>$%10.2f</u> \n"
level-0-balance)))
(html-table-row
(list name type l2-value l1-value
"&nbsp;" "&nbsp;"))))
(define (generate-balance-sheet-or-pnl report-name
report-description
balance-sheet?)
(define (render-total l0-value)
(html-table-row (list "&nbsp;" "&nbsp;" "&nbsp;" (html-strong "Net")
"&nbsp;" 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
"<html>"
@ -130,7 +128,7 @@
"<table cellpadding=1>"
"<caption><b>" (gnc:_ report-name) "</b></caption>"
"<tr><th>"(gnc:_ "Account Name")"<th align=center>"(gnc:_ "Type")
"<tr><th>"(gnc:_ "Account Name")"<th align=center>" (gnc:_ "Type")
"<th> <th align=center>"(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))))

44
src/scm/report/budget-report.scm
Unescape View File

@ -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))

11
src/scm/xml-generator.scm
Unescape View File

@ -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

Write Preview
Loading…
Cancel
Save