mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
*** empty log message ***
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2065 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas
parent
6ed86fbb29
commit
14b0d47c54
2
README
2
README
@ -245,8 +245,6 @@ fr_CH
|
||||
de_CH
|
||||
|
||||
|
||||
|
||||
|
||||
Other Tools
|
||||
-----------
|
||||
A tool to generate (ascii) reports from gnucash/xacc files can be found
|
||||
|
||||
82
src/scm/date-utilities.scm
Normal file
82
src/scm/date-utilities.scm
Normal file
@ -0,0 +1,82 @@
|
||||
;; -*-scheme-*-
|
||||
;; dateutils.scm
|
||||
;; date utility functions. mainly used by budget
|
||||
;; Bryan Larsen (blarsen@ada-works.com)
|
||||
|
||||
(gnc:support "dateutils.scm")
|
||||
|
||||
;; get stuff from localtime date vector
|
||||
(define (gnc:date-get-year datevec)
|
||||
(vector-ref datevec 5))
|
||||
(define (gnc:date-get-month-day datevec)
|
||||
(vector-ref datevec 3))
|
||||
;; get month with january==1
|
||||
(define (gnc:date-get-month datevec)
|
||||
(+ (vector-ref datevec 4) 1))
|
||||
(define (gnc:date-get-week-day datevec)
|
||||
(vector-ref datevec 6))
|
||||
(define (gnc:date-get-year-day datevec)
|
||||
(vector-ref datevec 7))
|
||||
|
||||
;; is leap year?
|
||||
(define (gnc:leap-year? year)
|
||||
(if (= (remainder year 4) 0)
|
||||
(if (= (remainder year 100) 0)
|
||||
(if (= (remainder year 400) 0) #t #f)
|
||||
#t)
|
||||
#f))
|
||||
|
||||
;; number of days in year
|
||||
(define (gnc:days-in-year year)
|
||||
(if (gnc:leap-year? year) 366 365))
|
||||
|
||||
;; number of days in month
|
||||
(define (gnc:days-in-month month year)
|
||||
(case month
|
||||
((1 3 5 7 8 10 12) 31)
|
||||
((4 6 9 11) 30)
|
||||
((2) (if (gnc:leap-year? year) 29 28))))
|
||||
|
||||
;; convert a date in seconds since 1970 into # of years since 1970 as
|
||||
;; a fraction.
|
||||
(define (gnc:date-to-year-fraction caltime)
|
||||
(let ((lt (localtime caltime)))
|
||||
(+ (- (gnc:date-get-year lt) 1970)
|
||||
(/ (gnc:date-get-year-day lt) (* 1.0 (gnc:days-in-year
|
||||
(gnc:date-get-year lt)))))))
|
||||
|
||||
;; convert a date in seconds since 1970 into # of months since 1970
|
||||
(define (gnc:date-to-month-fraction caltime)
|
||||
(let ((lt (localtime caltime)))
|
||||
(+ (* 12 (- (gnc:date-get-year lt) 1970.0))
|
||||
(/ (- (gnc:date-get-month-day lt) 1.0) (gnc:days-in-month
|
||||
(gnc:date-get-month lt)
|
||||
(gnc:date-get-year lt))))))
|
||||
|
||||
;; convert a date in seconds since 1970 into # of weeks since Jan 4, 1970
|
||||
;; ignoring leap-seconds
|
||||
(define (gnc:date-to-week-fraction caltime)
|
||||
(/ (- (/ (/ caltime 3600.0) 24) 3) 7))
|
||||
|
||||
;; convert a date in seconds since 1970 into # of days since Jan 1, 1970
|
||||
;; ignoring leap-seconds
|
||||
(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")))
|
||||
|
||||
@ -3,14 +3,18 @@
|
||||
|
||||
(gnc:support "html-generator.scm")
|
||||
|
||||
(define (html-table-row header? . items)
|
||||
(let loop
|
||||
((cline "<TR>")
|
||||
(ilist items))
|
||||
(if (pair? ilist)
|
||||
(loop (add-html-cell header? cline (car ilist))
|
||||
(cdr ilist))
|
||||
(string-append cline "</TR>"))))
|
||||
(define (html-table-row-manual items)
|
||||
(list
|
||||
'("<TR>")
|
||||
items
|
||||
'("</TR>")))
|
||||
|
||||
(define (html-table-row-guess header? strong? items)
|
||||
(html-table-row-manual
|
||||
(map
|
||||
(lambda (item)
|
||||
(html-cell header? strong? item))
|
||||
items)))
|
||||
|
||||
(define (html-strong cell)
|
||||
(string-append
|
||||
@ -18,28 +22,79 @@
|
||||
cell
|
||||
"</STRONG>"))
|
||||
|
||||
(define (add-html-cell header? cline item)
|
||||
(string-append cline (make-html-cell header? item)))
|
||||
(define (html-currency-cell header? strong? amount)
|
||||
(html-generic-cell
|
||||
#t
|
||||
header?
|
||||
strong?
|
||||
(string-append
|
||||
"<font face=\"Courier\""
|
||||
(if (< amount 0)
|
||||
(string-append
|
||||
"color=#ff0000>("
|
||||
(sprintf #f "%.2f" (- amount))
|
||||
")")
|
||||
(string-append
|
||||
"> "
|
||||
(sprintf #f "%.2f" amount)
|
||||
" "))
|
||||
"</font>")))
|
||||
|
||||
(define (make-html-cell header? item)
|
||||
(let ((pre ;;; Opening tag
|
||||
(cond
|
||||
(header? "<TH justify=center>")
|
||||
((number? item) "<TD ALIGN=RIGHT>")
|
||||
(else "<TD>")))
|
||||
(post ;;; Closing tag
|
||||
(if header? "</TH>" "</TD>")))
|
||||
(sprintf #f
|
||||
(string-append
|
||||
pre ;;; Start with opening tag
|
||||
(cond ;;; Body
|
||||
((string? item) item)
|
||||
((number? item) (sprintf #f "%.2f" item))
|
||||
(else ""))
|
||||
post)))) ;;; closing tag
|
||||
(define (html-generic-cell right-align? header? strong? item)
|
||||
(string-append
|
||||
(if header? "<TH justify=center" "<TD")
|
||||
(if right-align? " align=right>" ">")
|
||||
(if strong? "<strong>" "")
|
||||
item
|
||||
(if strong? "</strong>" "")
|
||||
(if header? "</TH>" "</TD>")))
|
||||
|
||||
(define (make-html-cell-header item)
|
||||
(make-html-cell #t item))
|
||||
(define (html-number-cell header? strong? format number)
|
||||
(html-generic-cell
|
||||
#t
|
||||
header?
|
||||
strong?
|
||||
(sprintf #f format number)))
|
||||
|
||||
(define (html-add-cell header? strong? cline item)
|
||||
(string-append cline (html-cell header? strong? item)))
|
||||
|
||||
;; guess at what type they want
|
||||
(define (html-cell header? strong? item)
|
||||
(cond ((string? item)
|
||||
(html-generic-cell #f header? strong? item))
|
||||
((number? item)
|
||||
(html-currency-cell header? strong? item))
|
||||
(else "")))
|
||||
|
||||
(define (html-cell-header item)
|
||||
(html-cell #t #f item))
|
||||
|
||||
(define (html-cell-body item)
|
||||
(html-cell #f #f item))
|
||||
|
||||
(define (html-cell-header-strong item)
|
||||
(html-cell #t #t item))
|
||||
|
||||
(define (html-cell-body-strong item)
|
||||
(html-cell #f #t item))
|
||||
|
||||
(define (html-cell-header-right item)
|
||||
(html-generic-cell #t #t #f item))
|
||||
|
||||
(define (html-start-document)
|
||||
(list
|
||||
"<HTML>"
|
||||
"<BODY bgcolor=#99ccff>"))
|
||||
|
||||
(define (html-end-document)
|
||||
(list
|
||||
"</BODY>"
|
||||
"</HTML>"))
|
||||
|
||||
(define (html-start-table)
|
||||
(list "<TABLE border=1>"))
|
||||
|
||||
(define (html-end-table)
|
||||
(list "</table>"))
|
||||
|
||||
(define (make-html-cell-body item)
|
||||
(make-html-cell #f item))
|
||||
|
||||
@ -131,3 +131,70 @@
|
||||
(if (equal? x (car lst))
|
||||
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
|
||||
(let subloop ((x (vector-ref input i)))
|
||||
(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 ...)
|
||||
;; the output vector will contain references to integer N in position N.
|
||||
;;
|
||||
;; example:
|
||||
;; #(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 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)))))
|
||||
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)))))
|
||||
|
||||
;; 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))))))))))
|
||||
|
||||
;; 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))))))))))
|
||||
|
||||
|
||||
|
||||
@ -1,25 +1,33 @@
|
||||
;; -*-scheme-*-
|
||||
;; budget-report.scm
|
||||
;; Report on budget
|
||||
;; uses some functions from transaction-report
|
||||
;; Bryan Larsen (blarsen@ada-works.com)
|
||||
|
||||
;; situations I want to handle
|
||||
;; lunch M-F
|
||||
;; lunch M-F -- funny period
|
||||
;; xmas gifts & birthday gifts in same budget line
|
||||
;; car repairs
|
||||
;; car fuel-ups
|
||||
;; paychecks & rent payments
|
||||
;; car repairs -- contingency
|
||||
;; car fuel-ups -- known amount, variable period
|
||||
;; paychecks & rent payments -- specific dates
|
||||
|
||||
(require 'sort)
|
||||
;(require 'time)
|
||||
(gnc:depend "report-utilities.scm")
|
||||
(gnc:depend "html-generator.scm")
|
||||
(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
|
||||
; that happen once per period
|
||||
(define gnc:budget-contingency 2) ; a budget item where you estimate a
|
||||
; value over a long period for
|
||||
; unexpected expenses.
|
||||
|
||||
;; define the budget itself. For prototype, define inline.
|
||||
;; the budget is a vector of vectors. the vectors contain:
|
||||
@ -31,8 +39,32 @@
|
||||
;; 4 - period-type:
|
||||
;; 5 - triggers: as yet undefined
|
||||
(define gnc:budget
|
||||
#(#("lunch" 8 ("Food:Lunch") 1 gnc:budget-day)
|
||||
#("junk food" 0.50 ("Food:Junk") 1 gnc:budget-day)))
|
||||
#(#("lunch" 8 ("Food:Lunch") 1 gnc:budget-day gnc:budget-recurring)
|
||||
#("junk food" 0.50 ("Food:Junk") 1 gnc:budget-day gnc:budget-recurring)
|
||||
#("car repairs" 2500 ("Car:Repairs") 5 gnc:budget-year gnc:budget-contingency)))
|
||||
|
||||
(define gnc:budget-headers
|
||||
#(("" "Description")
|
||||
("Amount" "per Period")
|
||||
("" "Accounts")
|
||||
("Period" "Size")
|
||||
("Period" "Size Units")
|
||||
("Budget" "Type")))
|
||||
|
||||
(define (gnc:budget-html-cell-pred)
|
||||
(vector
|
||||
(lambda (item)
|
||||
(html-generic-cell #f #f #f item))
|
||||
(lambda (item)
|
||||
(html-currency-cell #f #f item))
|
||||
(lambda (item)
|
||||
'()) ; todo: accounts
|
||||
(lambda (item)
|
||||
(html-number-cell #f #f "%i" item))
|
||||
(lambda (item)
|
||||
(html-generic-cell #f #f #f (gnc:date-describe-type item)))
|
||||
(lambda (item)
|
||||
'()))) ; todo: budget-type
|
||||
|
||||
(define (gnc:budget-get-description budget-line)
|
||||
(vector-ref budget-line 0))
|
||||
@ -51,187 +83,166 @@
|
||||
|
||||
;; budget report: a vector with indexes corresponding to the budget
|
||||
;; 0 - actual: the amount spend / recieved
|
||||
;; 1 - desired: the budgeted amount
|
||||
;; 1 - budgeted: the budgeted amount. Simply the periods * amount
|
||||
;; 2 - periods: the number of periods for the line in the report
|
||||
;; 3 - mimimum-expected: minimum you expected to spend during the
|
||||
;; report period
|
||||
;; 4 - maximum-expected: the maximum you can spend in the report period
|
||||
;; 5 - time remaining: how much of a period is remaining until the end
|
||||
;; of the budget period
|
||||
|
||||
(define gnc:budget-report-headers
|
||||
#(("Amount" "Spent")
|
||||
("Amount" "Budgeted")
|
||||
("Number of" "Periods")
|
||||
("Lower" "Limit")
|
||||
("Upper" "Limit")
|
||||
("Time" "Remaining")))
|
||||
|
||||
(define (gnc:budget-report-html-cell-pred)
|
||||
(vector
|
||||
(lambda (item)
|
||||
(html-currency-cell #f #f item))
|
||||
(lambda (item)
|
||||
(html-currency-cell #f #f item))
|
||||
(lambda (item)
|
||||
(html-number-cell #f #f "%.1f" item))
|
||||
(lambda (item)
|
||||
(html-currency-cell #f #f item))
|
||||
(lambda (item)
|
||||
(html-currency-cell #f #f item))
|
||||
(lambda (item)
|
||||
(html-number-cell #f #f "%.1f" item))))
|
||||
|
||||
(define (gnc:budget-report-get-actual brep-line)
|
||||
(vector-ref brep-line 0))
|
||||
|
||||
(define (gnc:budget-report-get-desired brep-line)
|
||||
(define (gnc:budget-report-get-budgeted brep-line)
|
||||
(vector-ref brep-line 1))
|
||||
|
||||
(define (gnc:budget-report-get-periods brep-line)
|
||||
(vector-ref brep-line 2))
|
||||
|
||||
;; accumulate the actual amounts for the budget given a split and
|
||||
;; a budget. returns the budget-report vector. The split is a 2 item list:
|
||||
;; account name and value
|
||||
;; obsolete
|
||||
(define (gnc:budget-report-accumulate-actual sub-split budget budget-report)
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (vector-length budget)) budget-report)
|
||||
(let ((budget-line (vector-ref budget i))
|
||||
(budget-report-line (vector-ref budget-report i))
|
||||
(name (car sub-split))
|
||||
(value (cadr sub-split)))
|
||||
(for-each
|
||||
(lambda (budget-account-name)
|
||||
(if (string-ci=? name budget-account-name)
|
||||
(begin
|
||||
(vector-set! budget-report-line 0
|
||||
(+ (gnc:budget-report-get-actual
|
||||
budget-report-line)
|
||||
value)))))
|
||||
(gnc:budget-get-accounts budget-line)))))
|
||||
(define (gnc:budget-report-get-minimum-expected brep-line)
|
||||
(vector-ref brep-line 3))
|
||||
|
||||
(define (gnc:budget-report-get-maximum-expected brep-line)
|
||||
(vector-ref brep-line 4))
|
||||
|
||||
(define (gnc:budget-report-get-time-remaining brep-line)
|
||||
(vector-ref brep-line 5))
|
||||
|
||||
;; add a value to the budget accumulator
|
||||
(define (gnc:budget-accumulate-actual value budget-report-line)
|
||||
(define (gnc:budget-accumulate-actual! value budget-report-line)
|
||||
(vector-set! budget-report-line 0
|
||||
(+ (gnc:budget-report-get-actual budget-report-line)
|
||||
value))
|
||||
budget-report-line)
|
||||
value)))
|
||||
|
||||
|
||||
;; convert budget-report to an html table
|
||||
(define (gnc:budget-report-to-html budget budget-report)
|
||||
(let ((budget-html ()))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (vector-length budget)) budget-html)
|
||||
(let ((budget-line (vector-ref budget i))
|
||||
(budget-report-line (vector-ref budget-report i)))
|
||||
(set! budget-html
|
||||
(append
|
||||
budget-html
|
||||
(list
|
||||
(string-append
|
||||
"<TR><TD>"
|
||||
(gnc:budget-get-description budget-line)
|
||||
"</TD><TD align=right>"
|
||||
(sprintf
|
||||
#f "%.1f"
|
||||
(gnc:budget-report-get-periods budget-report-line))
|
||||
"</TD><TD align=right>"
|
||||
(sprintf
|
||||
#f "%.2f" (gnc:budget-report-get-desired
|
||||
budget-report-line))
|
||||
"</TD><TD align=right>"
|
||||
(sprintf
|
||||
#f "%.2f" (gnc:budget-report-get-actual
|
||||
budget-report-line))
|
||||
"</TD><TD align=right>"
|
||||
(sprintf
|
||||
#f "%.2f" (- (gnc:budget-report-get-desired
|
||||
budget-report-line)
|
||||
(gnc:budget-report-get-actual
|
||||
budget-report-line)))
|
||||
"</TD></TR>"))))))))
|
||||
|
||||
;; given an account name, return the budget line number
|
||||
;; return #f if there is no budget line for that account
|
||||
(define (gnc:budget-get-line-number account-name budget)
|
||||
(let loop ((i 0))
|
||||
; (gnc:debug i)
|
||||
; (gnc:debug (car (gnc:budget-get-accounts (vector-ref budget i))))
|
||||
(cond ((= i (vector-length budget)) #f)
|
||||
((let loop2
|
||||
((accounts (gnc:budget-get-accounts (vector-ref budget i))))
|
||||
(cond ((null? accounts) #f)
|
||||
(else (or (string=? account-name (car accounts))
|
||||
(loop2 (cdr accounts)))))) i)
|
||||
; ((string=? account-name (car (gnc:budget-get-accounts (vector-ref budget i)))) i)
|
||||
(else (loop (+ i 1))))))
|
||||
|
||||
|
||||
;; get stuff from localtime date vector
|
||||
(define (gnc:date-get-year datevec)
|
||||
(vector-ref datevec 5))
|
||||
(define (gnc:date-get-month-day datevec)
|
||||
(vector-ref datevec 3))
|
||||
;; get month with january==1
|
||||
(define (gnc:date-get-month datevec)
|
||||
(+ (vector-ref datevec 4) 1))
|
||||
(define (gnc:date-get-week-day datevec)
|
||||
(vector-ref datevec 6))
|
||||
(define (gnc:date-get-year-day datevec)
|
||||
(vector-ref datevec 7))
|
||||
|
||||
;; is leap year?
|
||||
(define (gnc:leap-year? year)
|
||||
(if (= (remainder year 4) 0)
|
||||
(if (= (remainder year 100) 0)
|
||||
(if (= (remainder year 400) 0) #t #f)
|
||||
#t)
|
||||
#f))
|
||||
|
||||
;; number of days in year
|
||||
(define (gnc:days-in-year year)
|
||||
(if (gnc:leap-year? year) 366 365))
|
||||
|
||||
;; number of days in month
|
||||
(define (gnc:days-in-month month year)
|
||||
(case month
|
||||
((1 3 5 7 8 10 12) 31)
|
||||
((4 6 9 11) 30)
|
||||
((2) (if (gnc:leap-year? year) 29 28))))
|
||||
|
||||
;; convert a date in seconds since 1970 into # of years since 1970 as
|
||||
;; a fraction.
|
||||
(define (gnc:date-to-year-fraction caltime)
|
||||
(let ((lt (localtime caltime)))
|
||||
(+ (- (gnc:date-get-year lt) 1970)
|
||||
(/ (gnc:date-get-year-day lt) (* 1.0 (gnc:days-in-year
|
||||
(gnc:date-get-year lt)))))))
|
||||
|
||||
;; convert a date in seconds since 1970 into # of months since 1970
|
||||
(define (gnc:date-to-month-fraction caltime)
|
||||
(let ((lt (localtime caltime)))
|
||||
(+ (* 12 (- (gnc:date-get-year lt) 1970.0))
|
||||
(/ (- (gnc:date-get-month-day lt) 1.0) (gnc:days-in-month
|
||||
(gnc:date-get-month lt))))))
|
||||
|
||||
;; convert a date in seconds since 1970 into # of weeks since Jan 4, 1970
|
||||
;; ignoring leap-seconds
|
||||
(define (gnc:date-to-week-fraction caltime)
|
||||
(/ (- (/ (/ caltime 3600.0) 24) 3) 7))
|
||||
|
||||
;; convert a date in seconds since 1970 into # of days since Jan 1, 1970
|
||||
;; ignoring leap-seconds
|
||||
(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)))
|
||||
|
||||
;; calculate the # of periods on a budget line. return the budget report line
|
||||
;; calculate the # of periods on a budget line.
|
||||
;; dates are in # seconds after 1970
|
||||
(define (gnc:budget-calculate-periods budget-line budget-report-line
|
||||
(define (gnc:budget-calculate-periods! budget-line budget-report-line
|
||||
begin-date end-date)
|
||||
(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
|
||||
(/ (- end-N begin-N)
|
||||
(gnc:budget-get-period budget-line)))
|
||||
budget-report-line))
|
||||
(gnc:budget-get-period budget-line)))))
|
||||
|
||||
;; return what you are passed
|
||||
(define (null-filter)
|
||||
(lambda(x) x))
|
||||
;; calculate the budgeted value.
|
||||
;; dependency: budget-calculate-periods!
|
||||
(define (gnc:budget-calculate-budgeted! budget-line budget-report-line)
|
||||
(vector-set! budget-report-line 1
|
||||
(* (gnc:budget-get-amount budget-line)
|
||||
(gnc:budget-report-get-periods budget-report-line))))
|
||||
|
||||
;; calculate the expected budget value. return the budget report line
|
||||
(define (gnc:budget-calculate-expected budget-line budget-report-line
|
||||
begin-date end-date)
|
||||
;; calculate the values for minimum-expected and maxmimum-expected
|
||||
;; dependency: budget-calculate-periods!
|
||||
(define (gnc:budget-calculate-expected! budget-line budget-report-line)
|
||||
(begin
|
||||
(vector-set! budget-report-line 1
|
||||
(* (gnc:budget-get-amount budget-line)
|
||||
(gnc:budget-report-get-periods budget-report-line)))
|
||||
budget-report-line))
|
||||
(vector-set!
|
||||
budget-report-line 3
|
||||
(* (gnc:budget-get-amount budget-line)
|
||||
(floor (gnc:budget-report-get-periods budget-report-line))))
|
||||
(vector-set!
|
||||
budget-report-line 4
|
||||
(* (gnc:budget-get-amount budget-line)
|
||||
(ceiling (gnc:budget-report-get-periods budget-report-line))))))
|
||||
|
||||
;; 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)
|
||||
(vector-set!
|
||||
budget-report-line 5
|
||||
(* (- (ceiling (gnc:budget-report-get-periods budget-report-line))
|
||||
(gnc:budget-report-get-periods budget-report-line))
|
||||
(gnc:budget-get-period budget-line))))
|
||||
|
||||
;; given an account name, return the budget line number
|
||||
;; return #f if there is no budget line for that account
|
||||
(define (gnc:budget-get-line-number account-name budget)
|
||||
(let loop ((i 0))
|
||||
(cond ((= i (vector-length budget)) #f)
|
||||
((let loop2
|
||||
((accounts (gnc:budget-get-accounts (vector-ref budget i))))
|
||||
(cond ((null? accounts) #f)
|
||||
(else (or (string=? account-name (car accounts))
|
||||
(loop2 (cdr accounts)))))) i)
|
||||
(else (loop (+ i 1))))))
|
||||
|
||||
|
||||
;; register a configuration option for the budget report
|
||||
(define (budget-report-options-generator)
|
||||
|
||||
(define gnc:*budget-report-options* (gnc:new-options))
|
||||
|
||||
(define (gnc:register-budget-report-option new-option)
|
||||
(gnc:register-option gnc:*budget-report-options* new-option))
|
||||
|
||||
;; from date
|
||||
;; hack alert - could somebody set this to an appropriate date?
|
||||
(gnc:register-budget-report-option
|
||||
(gnc:make-date-option
|
||||
"Report Options" "From"
|
||||
"a" "Report start 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-budget-report-option
|
||||
(gnc:make-date-option
|
||||
"Report Options" "To"
|
||||
"b" "Report end date"
|
||||
(lambda () (cons (current-time) 0))
|
||||
#f))
|
||||
|
||||
;; view
|
||||
(gnc:register-budget-report-option
|
||||
(gnc:make-multichoice-option
|
||||
"Report Options" "View"
|
||||
"c" "Type of budget report"
|
||||
'status
|
||||
(list #(full
|
||||
"Full"
|
||||
"Show all columns")
|
||||
#(balancing
|
||||
"Balancing"
|
||||
"A report useful for balancing the budget")
|
||||
#(status
|
||||
"Status"
|
||||
"How are you doing on your budget?"))))
|
||||
|
||||
|
||||
gnc:*budget-report-options*)
|
||||
|
||||
|
||||
|
||||
(gnc:define-report
|
||||
@ -240,24 +251,11 @@
|
||||
;; Name
|
||||
"Budget"
|
||||
;; Options
|
||||
trep-options-generator
|
||||
budget-report-options-generator
|
||||
;; renderer
|
||||
(lambda (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"))
|
||||
(prefix (list "<HTML>" "<BODY bgcolor=#99ccff>"
|
||||
"<TABLE border=1>"
|
||||
"<TH>Description</TH>"
|
||||
"<TH>Number of Periods</TH>"
|
||||
"<TH>Amount Budgeted</TH>"
|
||||
"<TH>Amount Spent</TH>"
|
||||
"<TH>Delta</TH>"))
|
||||
(suffix (list "</TABLE>" "</BODY>" "</HTML>"))
|
||||
(input-transactions '())
|
||||
(budget-report #())
|
||||
(budget-html "")
|
||||
(date-filter-pred (gnc:tr-report-make-filter-predicate
|
||||
(gnc:option-value begindate)
|
||||
(gnc:option-value enddate)))
|
||||
@ -265,54 +263,87 @@
|
||||
(gnc:option-value begindate))))
|
||||
(end-date-secs (car (gnc:timepair-canonical-day-time
|
||||
(gnc:option-value enddate))))
|
||||
(accounts (gnc:option-value tr-report-account-op)))
|
||||
(set! budget-report (make-vector
|
||||
(vector-length gnc:budget)))
|
||||
(budget-report (make-vector (vector-length gnc:budget)))
|
||||
(budget-order #())
|
||||
(budget-report-order #()))
|
||||
(gnc:debug gnc:budget)
|
||||
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (vector-length gnc:budget)))
|
||||
(vector-set! budget-report i (vector 0 0 0)))
|
||||
(vector-set! budget-report i (vector 0 0 0 0 0 0)))
|
||||
|
||||
(let loop ((group (gnc:get-current-group)))
|
||||
(if (not (pointer-token-null? group))
|
||||
(gnc:group-map-accounts
|
||||
(lambda (account)
|
||||
(let* ((name (gnc:account-get-full-name account))
|
||||
(line (gnc:budget-get-line-number name gnc:budget))
|
||||
(children (gnc:account-get-children account)))
|
||||
(let ((line
|
||||
(gnc:budget-get-line-number
|
||||
(gnc:account-get-full-name account)
|
||||
gnc:budget))
|
||||
(children (gnc:account-get-children account)))
|
||||
(if line
|
||||
(gnc:for-each-split-in-account
|
||||
account
|
||||
(lambda (split)
|
||||
(vector-set!
|
||||
budget-report line
|
||||
(gnc:budget-accumulate-actual
|
||||
(gnc:budget-accumulate-actual!
|
||||
(gnc:split-get-value split)
|
||||
(vector-ref budget-report line))))))
|
||||
(if (not (pointer-token-null? children)) (loop children))))
|
||||
(vector-ref budget-report line)))))
|
||||
(loop children)))
|
||||
group)))
|
||||
(gnc:debug budget-report)
|
||||
(gnc:debug begin-date-secs)
|
||||
(gnc:debug end-date-secs)
|
||||
(gnc:debug (gnc:timepair-canonical-day-time
|
||||
(gnc:option-value begindate)))
|
||||
(gnc:debug (gnc:timepair-canonical-day-time
|
||||
(gnc:option-value enddate)))
|
||||
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (vector-length gnc:budget)))
|
||||
(vector-set! budget-report i
|
||||
(gnc:budget-calculate-expected
|
||||
(vector-ref gnc:budget i)
|
||||
(gnc:budget-calculate-periods
|
||||
(vector-ref gnc:budget i)
|
||||
(vector-ref budget-report i)
|
||||
begin-date-secs
|
||||
end-date-secs)
|
||||
begin-date-secs
|
||||
end-date-secs)))
|
||||
(let ((budget-line (vector-ref gnc:budget i))
|
||||
(budget-report-line (vector-ref budget-report i)))
|
||||
(gnc:budget-calculate-periods!
|
||||
budget-line budget-report-line begin-date-secs end-date-secs)
|
||||
(gnc:budget-calculate-budgeted! budget-line budget-report-line)
|
||||
(gnc:budget-calculate-expected! budget-line budget-report-line)
|
||||
(gnc:budget-calculate-time-remaining! budget-line budget-report-line)))
|
||||
|
||||
(gnc:debug budget-report)
|
||||
|
||||
(set! budget-html (gnc:budget-report-to-html
|
||||
gnc:budget budget-report))
|
||||
(case (gnc:option-value
|
||||
(gnc:lookup-option options "Report Options" "View"))
|
||||
((full)
|
||||
(set! budget-order (vector 1 2 #f 3 4 #f))
|
||||
(set! budget-report-order (vector 5 6 7 8 9 10)))
|
||||
((balancing)
|
||||
(set! budget-order #(1 2 #f 3 4 #f))
|
||||
(set! budget-report-order #(#f 6 5 #f #f #f)))
|
||||
((status)
|
||||
(set! budget-order #(1 #f #f #f 3 #f))
|
||||
(set! budget-report-order #(10 #f #f 4 5 2)))
|
||||
(else
|
||||
(gnc:debug "Invalid view option")))
|
||||
|
||||
(append prefix budget-html suffix))))
|
||||
(let ((order (find-vector-mappings
|
||||
(vector budget-order budget-report-order))))
|
||||
(list
|
||||
(html-start-document)
|
||||
"<p>This is a budget report. It is very preliminary, but you may find it useful. To actually change the budget, currently you have to edit budget-report.scm.</p>"
|
||||
(html-start-table)
|
||||
(html-table-row-manual
|
||||
(vector-map-in-specified-order
|
||||
(lambda (item) (html-cell-header (car item)))
|
||||
(vector gnc:budget-headers gnc:budget-report-headers)
|
||||
order))
|
||||
(html-table-row-manual
|
||||
(vector-map-in-specified-order
|
||||
(lambda (item) (html-cell-header (cadr item)))
|
||||
(vector gnc:budget-headers gnc:budget-report-headers)
|
||||
order))
|
||||
(let loop ((row 0))
|
||||
(cond ((= row (vector-length gnc:budget)) '())
|
||||
(else
|
||||
(cons
|
||||
(html-table-row-manual
|
||||
(vector-map-in-specified-order-uniquely
|
||||
(vector (gnc:budget-html-cell-pred)
|
||||
(gnc:budget-report-html-cell-pred))
|
||||
(vector (vector-ref gnc:budget row)
|
||||
(vector-ref budget-report row))
|
||||
order))
|
||||
(loop (+ row 1))))))
|
||||
(html-end-table)
|
||||
(html-end-document))))))
|
||||
Loading…
Reference in New Issue
Block a user