mirror of
https://github.com/Gnucash/gnucash.git
synced 2024-12-02 05:29:20 -06:00
Merge Chris Lam's 'maint-optimize-interval-charts' into maint.
This commit is contained in:
John Ralls
commit
a20a803c8e
@ -110,23 +110,26 @@
|
||||
(gnc:make-gnc-monetary currency numeric)))
|
||||
|
||||
(define layout-key-list
|
||||
(list (cons 'client (list (cons 'text "Client details")
|
||||
(cons 'tip "Client name and address")))
|
||||
;; Translators: "Their details" refer to the invoice 'other party' details i.e. client/vendor name/address/ID
|
||||
(list (cons 'client (list (cons 'text (_ "Their details"))
|
||||
(cons 'tip (_ "Client or vendor name, address and ID"))))
|
||||
|
||||
(cons 'company (list (cons 'text "Company details")
|
||||
(cons 'tip "Company name, address and tax-ID")))
|
||||
;; Translators: "Our details" refer to the book owner's details i.e. name/address/tax-ID
|
||||
(cons 'company (list (cons 'text (_ "Our details"))
|
||||
(cons 'tip (_ "Company name, address and tax-ID"))))
|
||||
|
||||
(cons 'invoice (list (cons 'text "Invoice details")
|
||||
(cons 'tip "Invoice date, due date, billing ID, terms, job details")))
|
||||
(cons 'invoice (list (cons 'text (_ "Invoice details"))
|
||||
(cons 'tip (_ "Invoice date, due date, billing ID, terms, job details"))))
|
||||
|
||||
(cons 'today (list (cons 'text "Today's date")
|
||||
(cons 'tip "Today's date")))
|
||||
(cons 'today (list (cons 'text (_ "Today's date"))
|
||||
(cons 'tip (_ "Today's date"))))
|
||||
|
||||
(cons 'picture (list (cons 'text "Picture")
|
||||
(cons 'tip "Picture")))
|
||||
(cons 'picture (list (cons 'text (_ "Picture"))
|
||||
(cons 'tip (_ "Picture"))))
|
||||
|
||||
(cons 'none (list (cons 'text "(empty)")
|
||||
(cons 'tip "Empty space")))))
|
||||
;; Translators: "(empty)" refers to invoice header section being left blank
|
||||
(cons 'none (list (cons 'text (_ "(empty)"))
|
||||
(cons 'tip (_ "Empty space"))))))
|
||||
|
||||
(define variant-list
|
||||
(list
|
||||
@ -333,6 +336,11 @@ for styling the invoice. Please see the exported report for the CSS class names.
|
||||
(N_ "Display") (N_ "Billing ID")
|
||||
"ta" (N_ "Display the billing id?") #t))
|
||||
|
||||
(gnc:register-inv-option
|
||||
(gnc:make-simple-boolean-option
|
||||
(N_ "Display") (N_ "Invoice owner ID")
|
||||
"tam" (N_ "Display the customer/vendor id?") #f))
|
||||
|
||||
(gnc:register-inv-option
|
||||
(gnc:make-simple-boolean-option
|
||||
(N_ "Display") (N_ "Invoice Notes")
|
||||
@ -669,7 +677,10 @@ for styling the invoice. Please see the exported report for the CSS class names.
|
||||
(gnc:make-html-text
|
||||
(gnc:html-markup-img img-url)))
|
||||
|
||||
(define (make-client-table owner orders)
|
||||
(define (make-client-table owner orders options)
|
||||
(define (opt-val section name)
|
||||
(gnc:option-value
|
||||
(gnc:lookup-option options section name)))
|
||||
;; this is a single-column table.
|
||||
(let ((table (gnc:make-html-table)))
|
||||
|
||||
@ -686,6 +697,14 @@ for styling the invoice. Please see the exported report for the CSS class names.
|
||||
(multiline-to-html-text
|
||||
(gnc:owner-get-address-dep owner)))))
|
||||
|
||||
(if (opt-val "Display" "Invoice owner ID")
|
||||
(gnc:html-table-append-row! table
|
||||
(list
|
||||
(gnc:make-html-div/markup
|
||||
"maybe-align-right client-id"
|
||||
(multiline-to-html-text
|
||||
(gnc:owner-get-owner-id owner))))))
|
||||
|
||||
(for-each
|
||||
(lambda (order)
|
||||
(let ((reference (gncOrderGetReference order)))
|
||||
@ -793,7 +812,8 @@ for styling the invoice. Please see the exported report for the CSS class names.
|
||||
invoice options)))
|
||||
(cons 'client (gnc:make-html-div/markup
|
||||
"client-table"
|
||||
(make-client-table owner orders)))
|
||||
(make-client-table
|
||||
owner orders options)))
|
||||
(cons 'company (gnc:make-html-div/markup
|
||||
"company-table"
|
||||
(make-company-table book)))
|
||||
|
||||
@ -392,42 +392,20 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
|
||||
;; This works similar as above but returns a commodity-collector,
|
||||
;; thus takes care of children accounts with different currencies.
|
||||
;;
|
||||
;; Also note that the commodity-collector contains <gnc:numeric>
|
||||
;; values rather than double values.
|
||||
(define (gnc:account-get-comm-balance-at-date account
|
||||
date include-children?)
|
||||
(define (gnc:account-get-comm-balance-at-date
|
||||
account date include-children?)
|
||||
(let ((balance-collector (gnc:make-commodity-collector))
|
||||
(query (qof-query-create-for-splits))
|
||||
(splits #f))
|
||||
|
||||
(if include-children?
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(balance-collector 'merge x #f))
|
||||
(gnc:account-map-descendants
|
||||
(lambda (child)
|
||||
(gnc:account-get-comm-balance-at-date child date #f))
|
||||
account)))
|
||||
|
||||
(qof-query-set-book query (gnc-get-current-book))
|
||||
(xaccQueryAddSingleAccountMatch query account QOF-QUERY-AND)
|
||||
(xaccQueryAddDateMatchTT query #f date #t date QOF-QUERY-AND)
|
||||
(qof-query-set-sort-order query
|
||||
(list SPLIT-TRANS TRANS-DATE-POSTED)
|
||||
(list QUERY-DEFAULT-SORT)
|
||||
'())
|
||||
(qof-query-set-sort-increasing query #t #t #t)
|
||||
(qof-query-set-max-results query 1)
|
||||
|
||||
(set! splits (qof-query-run query))
|
||||
(qof-query-destroy query)
|
||||
|
||||
(if (and splits (not (null? splits)))
|
||||
(balance-collector 'add
|
||||
(xaccAccountGetCommodity account)
|
||||
(xaccSplitGetBalance (car splits))))
|
||||
balance-collector))
|
||||
(accounts (cons account
|
||||
(if include-children?
|
||||
(gnc-account-get-descendants account)
|
||||
'()))))
|
||||
(for-each
|
||||
(lambda (acct)
|
||||
(balance-collector 'add
|
||||
(xaccAccountGetCommodity acct)
|
||||
(xaccAccountGetBalanceAsOfDate acct date)))
|
||||
accounts)
|
||||
balance-collector))
|
||||
|
||||
;; Calculate the increase in the balance of the account in terms of
|
||||
;; "value" (as opposed to "amount") between the specified dates.
|
||||
@ -435,41 +413,35 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
;; just direct children) are are included in the calculation. The results
|
||||
;; are returned in a commodity collector.
|
||||
(define (gnc:account-get-comm-value-interval account start-date end-date
|
||||
include-children?)
|
||||
include-children?)
|
||||
(let ((value-collector (gnc:make-commodity-collector))
|
||||
(query (qof-query-create-for-splits))
|
||||
(splits #f))
|
||||
|
||||
(if include-children?
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(value-collector 'merge x #f))
|
||||
(gnc:account-map-descendants
|
||||
(lambda (d)
|
||||
(gnc:account-get-comm-value-interval d start-date end-date #f))
|
||||
account)))
|
||||
(query (qof-query-create-for-splits))
|
||||
(accounts (cons account
|
||||
(if include-children?
|
||||
(gnc-account-get-descendants account)
|
||||
'()))))
|
||||
|
||||
;; Build a query to find all splits between the indicated dates.
|
||||
(qof-query-set-book query (gnc-get-current-book))
|
||||
(xaccQueryAddSingleAccountMatch query account QOF-QUERY-AND)
|
||||
(xaccQueryAddAccountMatch query accounts
|
||||
QOF-GUID-MATCH-ANY
|
||||
QOF-QUERY-AND)
|
||||
(xaccQueryAddDateMatchTT query
|
||||
(and start-date #t) (if start-date start-date 0)
|
||||
(and end-date #t) (if end-date end-date 0)
|
||||
(and start-date #t) (or start-date 0)
|
||||
(and end-date #t) (or end-date 0)
|
||||
QOF-QUERY-AND)
|
||||
|
||||
;; Get the query results.
|
||||
(set! splits (qof-query-run query))
|
||||
(qof-query-destroy query)
|
||||
|
||||
;; Add the "value" of each split returned (which is measured
|
||||
;; in the transaction currency).
|
||||
(for-each
|
||||
(lambda (split)
|
||||
(value-collector 'add
|
||||
(xaccTransGetCurrency (xaccSplitGetParent split))
|
||||
(xaccSplitGetValue split)))
|
||||
splits)
|
||||
|
||||
(let ((splits (qof-query-run query)))
|
||||
(qof-query-destroy query)
|
||||
;; Add the "value" of each split returned (which is measured
|
||||
;; in the transaction currency).
|
||||
(for-each
|
||||
(lambda (split)
|
||||
(value-collector 'add
|
||||
(xaccTransGetCurrency (xaccSplitGetParent split))
|
||||
(xaccSplitGetValue split)))
|
||||
splits))
|
||||
value-collector))
|
||||
|
||||
;; Calculate the balance of the account in terms of "value" (rather
|
||||
@ -633,34 +605,31 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
;; the type is an alist '((str "match me") (cased #f) (regexp #f))
|
||||
;; If type is #f, sums all non-closing splits in the interval
|
||||
(define (gnc:account-get-trans-type-balance-interval
|
||||
account-list type start-date end-date)
|
||||
account-list type start-date end-date)
|
||||
(let* ((total (gnc:make-commodity-collector)))
|
||||
(map (lambda (split)
|
||||
(let* ((shares (xaccSplitGetAmount split))
|
||||
(acct-comm (xaccAccountGetCommodity
|
||||
(xaccSplitGetAccount split)))
|
||||
(txn (xaccSplitGetParent split)))
|
||||
(if type
|
||||
(total 'add acct-comm shares)
|
||||
(if (not (xaccTransGetIsClosingTxn txn))
|
||||
(total 'add acct-comm shares)))))
|
||||
(gnc:account-get-trans-type-splits-interval
|
||||
account-list type start-date end-date))
|
||||
(for-each
|
||||
(lambda (split)
|
||||
(if (or type (not (xaccTransGetIsClosingTxn (xaccSplitGetParent split))))
|
||||
(total 'add
|
||||
(xaccAccountGetCommodity (xaccSplitGetAccount split))
|
||||
(xaccSplitGetAmount split))))
|
||||
(gnc:account-get-trans-type-splits-interval
|
||||
account-list type start-date end-date))
|
||||
total))
|
||||
|
||||
;; Sums up any splits of a certain type affecting a set of accounts.
|
||||
;; the type is an alist '((str "match me") (cased #f) (regexp #f))
|
||||
;; If type is #f, sums all splits in the interval (even closing splits)
|
||||
(define (gnc:account-get-trans-type-balance-interval-with-closing
|
||||
account-list type start-date end-date)
|
||||
account-list type start-date end-date)
|
||||
(let ((total (gnc:make-commodity-collector)))
|
||||
(map (lambda (split)
|
||||
(let* ((shares (xaccSplitGetAmount split))
|
||||
(acct-comm (xaccAccountGetCommodity
|
||||
(xaccSplitGetAccount split))))
|
||||
(total 'add acct-comm shares)))
|
||||
(gnc:account-get-trans-type-splits-interval
|
||||
account-list type start-date end-date))
|
||||
(for-each
|
||||
(lambda (split)
|
||||
(total 'add
|
||||
(xaccAccountGetCommodity (xaccSplitGetAccount split))
|
||||
(xaccSplitGetAmount split)))
|
||||
(gnc:account-get-trans-type-splits-interval
|
||||
account-list type start-date end-date))
|
||||
total))
|
||||
|
||||
;; Filters the splits from the source to the target accounts
|
||||
@ -757,44 +726,36 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
(define (gnc:account-get-trans-type-splits-interval
|
||||
account-list type start-date end-date)
|
||||
(if (null? account-list)
|
||||
;; No accounts given. Return empty list.
|
||||
'()
|
||||
;; The normal case: There are accounts given.
|
||||
(let* ((query (qof-query-create-for-splits))
|
||||
(query2 #f)
|
||||
(splits #f)
|
||||
(get-val (lambda (alist key)
|
||||
(let ((lst (assoc-ref alist key)))
|
||||
(if lst (car lst) lst))))
|
||||
(matchstr (get-val type 'str))
|
||||
(case-sens (if (get-val type 'cased) #t #f))
|
||||
(regexp (if (get-val type 'regexp) #t #f))
|
||||
(closing (if (get-val type 'closing) #t #f))
|
||||
)
|
||||
(qof-query-set-book query (gnc-get-current-book))
|
||||
(gnc:query-set-match-non-voids-only! query (gnc-get-current-book))
|
||||
(xaccQueryAddAccountMatch query account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
|
||||
(xaccQueryAddDateMatchTT
|
||||
query
|
||||
(and start-date #t) (if start-date start-date 0)
|
||||
(and end-date #t) (if end-date end-date 0)
|
||||
QOF-QUERY-AND)
|
||||
(if (or matchstr closing)
|
||||
(begin
|
||||
(set! query2 (qof-query-create-for-splits))
|
||||
(if matchstr (xaccQueryAddDescriptionMatch
|
||||
query2 matchstr case-sens regexp QOF-COMPARE-CONTAINS QOF-QUERY-OR))
|
||||
(if closing (xaccQueryAddClosingTransMatch query2 1 QOF-QUERY-OR))
|
||||
(qof-query-merge-in-place query query2 QOF-QUERY-AND)
|
||||
(qof-query-destroy query2)
|
||||
))
|
||||
|
||||
(set! splits (qof-query-run query))
|
||||
(qof-query-destroy query)
|
||||
splits
|
||||
)
|
||||
)
|
||||
)
|
||||
(let* ((query (qof-query-create-for-splits))
|
||||
(get-val (lambda (key)
|
||||
(let ((lst (assq-ref type key)))
|
||||
(and lst (car lst)))))
|
||||
(matchstr (get-val 'str))
|
||||
(case-sens (get-val 'cased))
|
||||
(regexp (get-val 'regexp))
|
||||
(closing (get-val 'closing)))
|
||||
(qof-query-set-book query (gnc-get-current-book))
|
||||
(gnc:query-set-match-non-voids-only! query (gnc-get-current-book))
|
||||
(xaccQueryAddAccountMatch query account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
|
||||
(xaccQueryAddDateMatchTT
|
||||
query
|
||||
(and start-date #t) (or start-date 0)
|
||||
(and end-date #t) (or end-date 0)
|
||||
QOF-QUERY-AND)
|
||||
(when (or matchstr closing)
|
||||
(let ((query2 (qof-query-create-for-splits)))
|
||||
(if matchstr
|
||||
(xaccQueryAddDescriptionMatch
|
||||
query2 matchstr case-sens regexp
|
||||
QOF-COMPARE-CONTAINS QOF-QUERY-OR))
|
||||
(if closing
|
||||
(xaccQueryAddClosingTransMatch query2 1 QOF-QUERY-OR))
|
||||
(qof-query-merge-in-place query query2 QOF-QUERY-AND)
|
||||
(qof-query-destroy query2)))
|
||||
(let ((splits (qof-query-run query)))
|
||||
(qof-query-destroy query)
|
||||
splits))))
|
||||
|
||||
;; utility to assist with double-column balance tables
|
||||
;; a request is made with the <req> argument
|
||||
@ -867,12 +828,12 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
;;
|
||||
;; Returns a commodity-collector.
|
||||
(define (gnc:budget-account-get-net budget account start-period end-period)
|
||||
(if (not end-period) (set! end-period (gnc-budget-get-num-periods budget)))
|
||||
(let* ((period (or start-period 0))
|
||||
(net (gnc:make-commodity-collector))
|
||||
(acct-comm (xaccAccountGetCommodity account)))
|
||||
(while (< period end-period)
|
||||
(net 'add acct-comm
|
||||
(maxperiod (or end-period (gnc-budget-get-num-periods budget)))
|
||||
(net (gnc:make-commodity-collector)))
|
||||
(while (< period maxperiod)
|
||||
(net 'add
|
||||
(xaccAccountGetCommodity account)
|
||||
(gnc-budget-get-account-period-value budget account period))
|
||||
(set! period (1+ period)))
|
||||
net))
|
||||
|
||||
@ -117,14 +117,27 @@
|
||||
(display render)))
|
||||
render)))
|
||||
|
||||
(define (strip-string s1 s2)
|
||||
(let loop ((str s1))
|
||||
(let ((startpos (string-contains str (format #f "<~a" s2)))
|
||||
(endpos (string-contains str (format #f "</~a>" s2))))
|
||||
(if (and startpos endpos)
|
||||
(loop (string-append
|
||||
(string-take str startpos)
|
||||
(string-drop str (+ endpos (string-length s2) 3))))
|
||||
str))))
|
||||
|
||||
(export gnc:options->sxml)
|
||||
(define (gnc:options->sxml uuid options prefix test-title)
|
||||
(define* (gnc:options->sxml uuid options prefix test-title #:key strip-tag)
|
||||
;; This functions calls the above gnc:options->render to render
|
||||
;; report. Then report is converted to SXML. It catches XML
|
||||
;; parsing errors, dumping the options changed.
|
||||
;; parsing errors, dumping the options changed. Also optionally strip
|
||||
;; an HTML tag from the render, e.g. <script>...</script>
|
||||
(let ((render (gnc:options->render uuid options prefix test-title)))
|
||||
(catch 'parser-error
|
||||
(lambda () (xml->sxml render
|
||||
(lambda () (xml->sxml (if strip-tag
|
||||
(strip-string render strip-tag)
|
||||
render)
|
||||
#:trim-whitespace? #t
|
||||
#:entities '((nbsp . "\xa0"))))
|
||||
(lambda (k . args)
|
||||
|
||||
@ -555,17 +555,15 @@
|
||||
table columns)
|
||||
(for-each
|
||||
(lambda (row)
|
||||
(gnc:html-table-append-row! table row))
|
||||
(gnc:html-table-append-row!
|
||||
table
|
||||
(map
|
||||
gnc:make-html-table-cell/markup
|
||||
(list "date-cell" "date-cell"
|
||||
"number-cell" "number-cell" "number-cell"
|
||||
"number-cell" "number-cell" "number-cell")
|
||||
row)))
|
||||
data)
|
||||
|
||||
;; set numeric columns to align right
|
||||
(for-each
|
||||
(lambda (col)
|
||||
(gnc:html-table-set-col-style!
|
||||
table col "td"
|
||||
'attribute (list "align" "right")))
|
||||
'(2 3 4 5 6 7))
|
||||
|
||||
(gnc:html-document-add-object! document table))))
|
||||
|
||||
;; if there are no accounts selected...
|
||||
|
||||
@ -33,8 +33,6 @@
|
||||
(use-modules (gnucash gnc-module))
|
||||
(use-modules (gnucash gettext))
|
||||
|
||||
(use-modules (gnucash report report-system report-collectors))
|
||||
(use-modules (gnucash report report-system collectors))
|
||||
(use-modules (gnucash report standard-reports category-barchart)) ; for guids of called reports
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
@ -306,50 +304,16 @@
|
||||
|
||||
(if
|
||||
(not (null? accounts))
|
||||
(let* ((the-account-destination-alist
|
||||
(if inc-exp?
|
||||
(append (map (lambda (account) (cons account 'asset))
|
||||
(assoc-ref classified-accounts ACCT-TYPE-INCOME))
|
||||
(map (lambda (account) (cons account 'liability))
|
||||
(assoc-ref classified-accounts ACCT-TYPE-EXPENSE)))
|
||||
(append (map (lambda (account) (cons account 'asset))
|
||||
(assoc-ref classified-accounts ACCT-TYPE-ASSET))
|
||||
(map (lambda (account) (cons account 'liability))
|
||||
(assoc-ref classified-accounts ACCT-TYPE-LIABILITY)))))
|
||||
(account-reformat (if inc-exp?
|
||||
(lambda (account result)
|
||||
(map (lambda (collector date-interval)
|
||||
(gnc:monetary-neg (collector->monetary collector (second date-interval))))
|
||||
result dates-list))
|
||||
(lambda (account result)
|
||||
(let ((commodity-collector (gnc:make-commodity-collector)))
|
||||
(collector-end (fold (lambda (next date list-collector)
|
||||
(commodity-collector 'merge next #f)
|
||||
(collector-add list-collector
|
||||
(collector->monetary
|
||||
commodity-collector date)))
|
||||
(collector-into-list)
|
||||
result
|
||||
dates-list))))))
|
||||
(work (category-by-account-report-work inc-exp?
|
||||
dates-list
|
||||
the-account-destination-alist
|
||||
(lambda (account date)
|
||||
(make-gnc-collector-collector))
|
||||
account-reformat))
|
||||
(rpt (category-by-account-report-do-work work (cons 50 90)))
|
||||
(assets (assoc-ref rpt 'asset))
|
||||
(liabilities (assoc-ref rpt 'liability))
|
||||
(assets-list (if assets
|
||||
(car assets)
|
||||
(map (lambda (d)
|
||||
(gnc:make-gnc-monetary report-currency 0))
|
||||
dates-list)))
|
||||
(liability-list (if liabilities
|
||||
(car liabilities)
|
||||
(map (lambda (d)
|
||||
(gnc:make-gnc-monetary report-currency 0))
|
||||
dates-list)))
|
||||
(let* ((assets-list (process-datelist
|
||||
(if inc-exp?
|
||||
accounts
|
||||
(assoc-ref classified-accounts ACCT-TYPE-ASSET))
|
||||
dates-list #t))
|
||||
(liability-list (process-datelist
|
||||
(if inc-exp?
|
||||
accounts
|
||||
(assoc-ref classified-accounts ACCT-TYPE-LIABILITY))
|
||||
dates-list #f))
|
||||
(net-list (map monetary+ assets-list liability-list))
|
||||
;; Here the date strings for the x-axis labels are
|
||||
;; created.
|
||||
|
||||
@ -45,12 +45,8 @@
|
||||
(define (run-test)
|
||||
(test-runner-factory gnc:test-runner)
|
||||
(test-begin "net-charts.scm")
|
||||
(for-each (lambda (variant)
|
||||
(null-test variant))
|
||||
(map car variant-alist))
|
||||
(for-each (lambda (variant)
|
||||
(net-charts-test variant))
|
||||
(map car variant-alist))
|
||||
(for-each null-test (map car variant-alist))
|
||||
(for-each test-chart (map car variant-alist))
|
||||
(test-end "net-charts.scm"))
|
||||
|
||||
(define (options->render variant options test-title)
|
||||
@ -74,7 +70,12 @@
|
||||
(test-assert (format #f "null-test: ~a" variant)
|
||||
(options->render uuid options "null-test"))))
|
||||
|
||||
(define (net-charts-test variant)
|
||||
(define (test-chart variant)
|
||||
(test-group-with-cleanup (format #f "test variant ~a" variant)
|
||||
(test-chart-variant variant)
|
||||
(gnc-clear-current-session)))
|
||||
|
||||
(define (test-chart-variant variant)
|
||||
(define (set-option! options section name value)
|
||||
(let ((option (gnc:lookup-option options section name)))
|
||||
(if option
|
||||
@ -115,7 +116,54 @@
|
||||
|
||||
(let* ((options (default-testing-options)))
|
||||
(test-assert (format #f "basic report exists: ~a" variant)
|
||||
(options->render uuid options (format #f "net-charts-test ~a default options" variant))))
|
||||
(options->render uuid options (format #f "test-null ~a default options" variant))))
|
||||
|
||||
;; test net worth barchart amounts
|
||||
(when (or (eq? variant 'net-worth-barchart)
|
||||
(eq? variant 'income-expense-barchart))
|
||||
;; create 100 daily transactions from 1/1/70. this is meant to
|
||||
;; test chart date ranges. day 0 = $0, day 1 = $1, etc
|
||||
(let loop ((date (gnc-dmy2time64 1 1 1970)) (idx 0))
|
||||
(when (<= idx 100)
|
||||
(env-create-transaction env date bank income idx)
|
||||
(loop (incdate date DayDelta) (1+ idx))))
|
||||
(when (eq? variant 'net-worth-barchart)
|
||||
(let* ((options (default-testing-options)))
|
||||
(set-option! options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 15 1 1970)))
|
||||
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 15 3 1970)))
|
||||
(set-option! options "General" "Step Size" 'DayDelta)
|
||||
(set-option! options "Display" "Show table" #t)
|
||||
(let ((sxml (gnc:options->sxml uuid options (format #f "test-net-charts ~a 2 months" variant)
|
||||
"test-table" #:strip-tag "script")))
|
||||
(test-equal "net-worth-barchart: first row"
|
||||
'("Date" "Assets" "Liabilities" "Net Worth")
|
||||
(sxml->table-row-col sxml 1 0 #f))
|
||||
(test-equal "net-worth-barchart: first data row"
|
||||
'("01/15/70" "$105.00" "$0.00" "$105.00")
|
||||
(sxml->table-row-col sxml 1 1 #f))
|
||||
(test-equal "net-worth-barchart: last data row"
|
||||
'("03/15/70" "$2,701.00" "$0.00" "$2,701.00")
|
||||
(sxml->table-row-col sxml 1 -1 #f)))))
|
||||
|
||||
(when (eq? variant 'income-expense-barchart)
|
||||
(let* ((options (default-testing-options)))
|
||||
(set-option! options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 15 1 1970)))
|
||||
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 15 3 1970)))
|
||||
(set-option! options "General" "Step Size" 'DayDelta)
|
||||
(set-option! options "Display" "Show table" #t)
|
||||
(set-option! options "Accounts" "Accounts" (list income expense))
|
||||
(let ((sxml (gnc:options->sxml uuid options (format #f "test-net-charts ~a 2 years" variant)
|
||||
"test-table" #:strip-tag "script")))
|
||||
(test-equal "income-expense-barchart: first row"
|
||||
'("Date" "Income" "Expense" "Net Profit")
|
||||
(sxml->table-row-col sxml 1 0 #f))
|
||||
(test-equal "income-expense: first data row"
|
||||
'("01/15/70" "$14.00" "$0.00" "$14.00")
|
||||
(sxml->table-row-col sxml 1 1 #f))
|
||||
(test-equal "income-expense: last data row"
|
||||
'("03/15/70" "$73.00" "$0.00" "$73.00")
|
||||
(sxml->table-row-col sxml 1 -1 #f))))
|
||||
))
|
||||
|
||||
(case variant
|
||||
((liability-piechart stock-piechart asset-piechart expense-piechart income-piechart)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user