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

Merge Chris Lam's 'maint-optimize-interval-charts' into maint.

Browse Source
pull/412/merge
John Ralls 8 years ago
parent 766dc9b2d5 395b42d620
commit a20a803c8e
6 changed files with 209 additions and 205 deletions
Show Stats Download Patch File Download Diff File

48
gnucash/report/business-reports/invoice.scm
Unescape View File

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

209
gnucash/report/report-system/report-utilities.scm
Unescape View File

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

19
gnucash/report/report-system/test/test-extras.scm
Unescape View File

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

18
gnucash/report/standard-reports/average-balance.scm
Unescape View File

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

56
gnucash/report/standard-reports/net-charts.scm
Unescape View File

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

64
gnucash/report/standard-reports/test/test-charts.scm
Unescape View File

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

Write Preview
Loading…
Cancel
Save