· 8 years ago · May 11, 2018, 10:56 AM
1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;; current-vs-average.scm : Show comparison between current and average account values or transactions
3;; in account(s) in multiple periods
4;;
5;; Based on transaction.scm originally by Robert Merkel <rgmerk@mira.net>
6;; Contributions by Bryan Larsen <blarsen@ada-works.com>,
7;; Christian Stimming <stimming@tuhh.de>, Michael T. Garrison Stuber,
8;; Tomas Pospisek <tpo_deb@sourcepole.ch> with a lot of help from "warlord",
9;; D.B.Doughty <dbdoughty at gmail.com>
10;; Comparison report developed by D.B.Doughty <dbdoughty at gmail.com>
11
12
13;; This program is free software; you can redistribute it and/or
14;; modify it under the terms of the GNU General Public License as
15;; published by the Free Software Foundation; either version 2 of
16;; the License, or (at your option) any later version.
17;;
18;; This program is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22;;
23;; You should have received a copy of the GNU General Public License
24;; along with this program; if not, contact:
25;;
26;; Free Software Foundation Voice: +1-617-542-5942
27;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
28;; Boston, MA 02110-1301, USA gnu@gnu.org
29;;
30;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31
32; potential items to-do?
33; 1. create delta table col1 = base col2 on = delta (base - period)
34
35
36(define-module (gnucash report standard-reports current-vs-average))
37
38;;(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
39(use-modules (srfi srfi-1))
40(use-modules (gnucash gnc-module))
41(use-modules (gnucash gettext))
42
43;;(use-modules (gnucash printf))
44;
45
46;;following line is step 1 of 4 needed to add gnctimeperiod-utilities
47(use-modules (gnucash gnctimeperiod-utilities))
48
49;;following line is needed for consolidating/ compostite transactions
50;; since gnc:register-guid is not being exported in report-system.scm for html-utilities.scm
51(gnc:module-load "gnucash/html" 0)
52
53(gnc:module-load "gnucash/report/report-system" 0)
54
55(define-macro (addto! alist element)
56 `(set! ,alist (cons ,element ,alist)))
57
58;; Define the strings here to avoid typos and make changes easier.
59(define reportname (N_ "Current versus Average Report"))
60(define pagename-accounts (N_ "Accounts"))
61(define pagename-sorting (N_ "Sorting"))
62(define pagename-general (N_ "General"))
63(define pagename-display (N_ "Display"))
64(define optname-prime-sortkey (N_ "Primary Key"))
65(define optname-prime-subtotal (N_ "Primary Subtotal"))
66(define optname-prime-date-subtotal (N_ "Primary Subtotal for Date Key"))
67(define optname-sec-sortkey (N_ "Secondary Key"))
68(define optname-sec-subtotal (N_ "Secondary Subtotal"))
69(define optname-sec-date-subtotal (N_ "Secondary Subtotal for Date Key"))
70(define optname-void-transactions (N_ "Void Transactions"))
71(define optname-table-export (N_ "Table for Exporting"))
72(define optname-common-currency (N_ "Common Currency"))
73(define optname-currency (N_ "Report's currency"))
74(define def:grand-total-style "grand-total")
75(define def:normal-row-style "normal-row")
76(define def:alternate-row-style "alternate-row")
77(define def:primary-subtotal-style "primary-subheading")
78(define def:secondary-subtotal-style "secondary-subheading")
79
80;; added for find
81(define optname-find-text? (N_ "Find Text"))
82(define optname-find1-field (N_ "Search"))
83(define optname-find1-text (N_ "finding the text"))
84(define optname-find2-operand (N_ "Search for entries containing above string "))
85(define optname-find2-field (N_ "Search for 2nd string in "))
86(define optname-find2-text (N_ "2nd string"))
87(define optname-find-min (N_ "Find minimum amount"))
88(define optname-find-max (N_ "Find maximum ammount"))
89
90(define optname-days (N_ "Days"))
91
92(define text-containing ", containing " )
93(define text-and " and ")
94(define text-or " or ")
95(define text-but-not " but not ")
96(define text-minimum ", Minimum ")
97(define text-maximum ", Maximum ")
98
99;; added for consolidating
100(define consolidated-text "Consolidated")
101(define optname-consolidate-case-sensitive (N_ "-- make consolidation case-sensitive"))
102
103
104(define optname-descript-titlecase (N_ "Titlecase the first chracter in each word in description"))
105
106(define 4weeks "4 weeks")
107(define 8weeks "8 weeks")
108(define 12weeks "12 weeks")
109(define 13weeks "13 weeks")
110(define 26weeks "26 weeks")
111(define 52weeks "52 weeks")
112(define 3months "3 months")
113(define 4months "4 months")
114(define 6months "6 months")
115(define 9months "9 months")
116(define 12months "12 months")
117(define 18months "18 months")
118(define 24months "24 months")
119
120;; add for averaging
121(define show-average? #t)
122
123;; add for scaling
124(define scaling-text "Note: amount and balance have been scaled.")
125
126;; added for flagging imbalances when account name is primary key
127(define optname-show-imbalance
128 (N_ "Note any imbalance"))
129(define opthelp-show-imbalance
130 (N_ "Make a footnote if there is an imbalance when account name or account code is selected as the primary key and find not used"))
131
132(define text-note-account " Note - account ")
133(define text-changed-in-value " in the base period changed in value by ")
134(define text-dash (_ "-")) ; printed to indicate imbalance was checked for
135
136;; for find
137(define list-findchoices
138 (list (list->vector
139 (list 'description
140 (N_ "description ")
141 (N_ "search descriptions or transactions for the text - note a blank is added at start and end of description")))
142 (list->vector
143 (list 'account-name
144 (N_ "account name")
145 (N_ "search full account name ")))
146 (list->vector
147 (list 'account-code
148 (N_ "account code")
149 (N_ "search account code")))
150 (list->vector
151 (list 'memo
152 (N_ "memo ")
153 (N_ "Search only memo field")))
154 (list->vector
155 (list 'notes
156 (N_ "notes ")
157 (N_ "search only notes")))
158 (list->vector
159 (list 'memo/notes
160 (N_ "memo/notes ")
161 (N_ "search both memo and notes")))
162 (list->vector
163 (list 'number
164 (N_ "check number ")
165 (N_ "search check number and transaction number field")))
166 (list->vector
167 (list 'date
168 (N_ "date ")
169 (N_ "search date ( a space has been added in front date and after date) ")))
170 (list->vector
171 (list 'reconciled-date
172 (N_ "reconciled date ")
173 (N_ "search reconciled date ( a space has been added in front of and after reconciled date)")))
174 (list->vector
175 (list 'reconcile
176 (N_ "reconcile ")
177 (N_ "search reconcile field (y,n,c,f) (a space has been added in front of and after reconcile character)")))
178 (list->vector
179 (list 'any
180 (N_ "any ")
181 (N_ "search description and account-name and account-code and memo and notes ")))
182 )
183)
184
185(define list-find2-operands
186 (list (list->vector
187 (list 'none
188 (N_ " ONLY " )
189 (N_ "do not look for a second string of text")))
190 (list->vector
191 (list 'and
192 (N_ "and the 2nd string ")
193 (N_ "the transaction also must include the second text string")))
194 (list->vector
195 (list 'or
196 (N_ "or the 2nd string")
197 (N_ "search for either of the two text strings ")))
198 (list->vector
199 (list 'not
200 (N_ "but exclude entries with 2nd string")
201 (N_ "Search transactions that do not include the second text string")))
202 )
203)
204
205;; this is step 2 of 4
206;; needed for gnctimeperiod-utilities
207;; define all option's names so that they are properly defined
208;; in *one* place.
209;; can change following text for local language
210
211;; following value may need to be changed
212(define the_tab pagename-general)
213
214(define text-whichperiod "Select Period")
215(define text-customdates "Custom Dates")
216(define custom-from-date (N_ "Custom_Start Date"))
217(define custom-to-date (N_ "Custom_End Date"))
218(define text-pick-year "Year for Specified Pick")
219(define text-period "Specified Period")
220(define text-last "Specified Last")
221(define text-month "Specified Month")
222
223(define text-average "Average period")
224(define text-exclude-average "Do not include last period in average")
225(define text-number-days " Number of Days:")
226
227; for compare
228(define pagename-compare (N_ "Compare"))
229(define optname-compare? (N_ "Compare periods?"))
230(define optname-no-base? (N_ "Do not show base period, only comparison periods"))
231(define optname-scale-automatically? (N_ "Ignore other scaling and"))
232(define optname-scale-to (N_ "scale to"))
233(define text-whichcompareperiod "Select Comparison Period")
234(define text-compare-divide "divide period into")
235
236(define optname-show-average? (N_ "Show average of compare periods"))
237
238(define splits '())
239
240(define gnc:list-datechoices
241 (list (list->vector
242 (list 'customdates
243 (N_ text-customdates)
244 (N_ "use selected dates and ignore specific choices")))
245 (list->vector
246 (list 'period
247 (N_ text-period)
248 (N_ "which period to use")))
249 (list->vector
250 (list 'last
251 (N_ text-last)
252 (N_ "when to use")))
253 (list->vector
254 (list 'month
255 (N_ text-month)
256 (N_ "use specific month")))
257 )
258)
259
260(define gnc:list-datechoices-avg
261 (list (list->vector
262 (list 'customdates
263 (N_ text-customdates)
264 (N_ "use selected dates and ignore specific choices")))
265 (list->vector
266 (list 'period
267 (N_ text-period)
268 (N_ "which period to use")))
269 (list->vector
270 (list 'last
271 (N_ text-last)
272 (N_ "when to use")))
273 (list->vector
274 (list 'month
275 (N_ text-month)
276 (N_ "use specific month")))
277 (list->vector
278 (list 'average
279 (N_ text-average)
280 (N_ "Use time period from average list of choices")))
281 )
282)
283(define gnc:list-average
284 (list (list->vector
285 (list '4weeks
286 (N_ 4weeks)
287 (N_ "4 weeks")))
288 (list->vector
289 (list '8weeks
290 (N_ 8weeks)
291 (N_ "8 weeks")))
292 (list->vector
293 (list '12weeks
294 (N_ 12weeks)
295 (N_ "12 weeks")))
296 (list->vector
297 (list '13weeks
298 (N_ 13weeks)
299 (N_ "13 weeks")))
300 (list->vector
301 (list '26weeks
302 (N_ 26weeks)
303 (N_ "26 weeks")))
304 (list->vector
305 (list '52weeks
306 (N_ 52weeks)
307 (N_ "52 weeks")))
308 (list->vector
309 (list '3months
310 (N_ 3months)
311 (N_ "3 months")))
312 (list->vector
313 (list '4months
314 (N_ 4months)
315 (N_ "4 months")))
316 (list->vector
317 (list '6months
318 (N_ 6months)
319 (N_ "6 months")))
320 (list->vector
321 (list '9months
322 (N_ 9months)
323 (N_ "9 months")))
324 (list->vector
325 (list '12months
326 (N_ 12months)
327 (N_ "12 months")))
328 (list->vector
329 (list '18months
330 (N_ 18months)
331 (N_ "18 months")))
332 (list->vector
333 (list '24months
334 (N_ 24months)
335 (N_ "24 months")))
336 )
337)
338 (define scale-num
339 (list
340 (cons '* (vector gnc-numeric-mul (N_ "multiplied by ")))
341 (cons '/ (vector gnc-numeric-div (N_ "divided by ")))
342 ))
343
344;; end of section 2 needed for gnctimeperiod-utilities
345
346(define show-days? #t)
347
348(define now (timespecCanonicalDayTime (cons (current-time) 0)))
349(define today-tm (gnc:timepair->date now))
350
351(define period_start (gnc:timepair->date now))
352(define period_end (gnc:timepair->date now))
353
354(define (gnc:date-lt? tm1 tm2)
355 (if (not (= (tm:year tm1) (tm:year tm2)))
356 (< (tm:year tm1) (tm:year tm2))
357 ; years match
358 (< (gnc:day-of-year tm1) (gnc:day-of-year tm2))
359 ))
360
361(define (getdates-average entrypicked exclude-last-period?)
362(begin
363(set! period_start (gnc:timepair->date now))
364(set! period_end (gnc:timepair->date now))
365(let ((day (gnc:day-of-week period_end))
366 (fiscal-start (gnc:timepair->date (gnc:secs->timepair (gnc-accounting-period-fiscal-start))))
367 ; (fiscal-month 0)
368 (fiscal-day 1)
369 )
370 ;use period_end for weeks
371 (set! fiscal-day (tm:mday fiscal-start))
372 (set! period_end (gnc:decrement-date period_end (+ day 1) ))
373 (if exclude-last-period?
374 (set! period_end (gnc:decrement-date period_end 7 )))
375
376 ;use period_start for months
377 (set-tm:mday period_start fiscal-day)
378 (if (gnc:date-lt? today-tm (gnc:decrement-date period_start 1 ))
379 (begin
380 (set-tm:mon period_start (- (tm:mon period_start) 1))
381 ))
382 (if exclude-last-period?
383 (set! period_start (gnc:decrement-month period_start 1)))
384
385 (case entrypicked
386 ((4weeks)
387 (set! period_start (gnc:decrement-date period_end (+ 6 (* 7 3)))))
388 ((8weeks)
389 (set! period_start (gnc:decrement-date period_end (+ 6 (* 7 7)))))
390 ((12weeks)
391 (set! period_start (gnc:decrement-date period_end (+ 6 (* 7 11)))))
392 ((13weeks)
393 (set! period_start (gnc:decrement-date period_end (+ 6 (* 7 12)))))
394 ((26weeks)
395 (set! period_start (gnc:decrement-date period_end (+ 6 (* 7 25)))))
396 ((52weeks)
397 (set! period_start (gnc:decrement-date period_end (+ 6 (* 7 51)))))
398 ((3months)
399 (set! period_start (gnc:decrement-month period_start 3))
400 (set! period_end (gnc:increment-month-less-1-day period_start 3))
401 )
402 ((4months)
403 (set! period_start (gnc:decrement-month period_start 4))
404 (set! period_end (gnc:increment-month-less-1-day period_start 4))
405 )
406 ((6months)
407 (set! period_start (gnc:decrement-month period_start 6))
408 (set! period_end (gnc:increment-month-less-1-day period_start 6))
409 )
410 ((9months)
411 (set! period_start (gnc:decrement-month period_start 9))
412 (set! period_end (gnc:increment-month-less-1-day period_start 9))
413 )
414 ((12months)
415 (set! period_start (gnc:decrement-month period_start 12))
416 (set! period_end (gnc:increment-month-less-1-day period_start 12))
417 )
418 ((18months)
419 (set! period_start (gnc:decrement-month period_start 18))
420 (set! period_end (gnc:increment-month-less-1-day period_start 18))
421 )
422 ((24months)
423 (set! period_start (gnc:decrement-month period_start 24))
424 (set! period_end (gnc:increment-month-less-1-day period_start 24))
425 )
426 )
427
428(list (gnc:timepair-start-day-time (gnc:date->timepair period_start))
429 (gnc:timepair-end-day-time (gnc:date->timepair period_end)) )
430)))
431
432;for find
433
434(define do-find? #f)
435(define do-findamount? #f)
436(define find-min? #f)
437(define find-max? #f)
438(define find-text? #f)
439(define find1-field 'description )
440(define find2-operand 'and)
441(define find1-text "text to find")
442(define find2-field 'description )
443(define find2-text "description to find")
444
445(define find-min 100.00)
446(define find-max 100.00)
447(define findtitle "")
448
449
450;;for running balance
451(define amount-total-hash (make-hash-table))
452
453;;for scaling
454(define scale-op-val '*)
455(define scale-num-val 1)
456(define scaled? #f)
457(define compare-scale-automatically? #f)
458(define compare-scale-to-val 1)
459
460;;for scaling comparison period
461(define scale-op-val2 '*)
462(define scale-num-val2 1)
463
464(define description-titlecase? #t)
465(define columns-headings 0)
466
467;; for consolidate descriptions (create composite - to combine multiple entries with same payee)
468(define curr " ")
469(define comm-curr? #f)
470(define currency-type-num 1)
471(define currency-type-str "1")
472
473(define list_of_trans '())
474(define sort-date-type 7)
475
476(define currency-col-type 1)
477
478(define primary-subtotal-collector-hash (make-hash-table))
479(define secondary-subtotal-collector-hash (make-hash-table))
480(define total-collector-hash (make-hash-table))
481
482(define (sort-test x y var-p var-s comp-p1 comp-p2 comp-s1 comp-s2 )
483
484 (define (test? x y)
485 (let ((primary-x (var-p x))
486 (primary-y (var-p y))
487 (secondary-x (var-s x))
488 (secondary-y (var-s y)) )
489 (if (not (comp-p1 primary-x primary-y ))
490 (comp-p2 primary-x primary-y)
491 (if (not (comp-s1 secondary-x secondary-y))
492 (comp-s2 secondary-x secondary-y )
493 (string-ci<=? (get-description x) (get-description y)))
494 ))
495 )
496 (test? x y)
497)
498
499
500
501(define payee-hash (make-hash-table) )
502(define payee-account-guid-hash (make-hash-table))
503(define currency-type-hash (make-hash-table) )
504(define currency-lookup-hash (make-hash-table) )
505
506(define pointer-hash (make-hash-table))
507(define amounts-array (make-array #f 2 3)) ; col 0 = currency type ; col 1 and greater - period
508(define guid-array (make-array #f 2 3))
509(define row-number 2); row 0 heading row 1 number of days in the period
510(define last-column 1)
511(define period-number 0)
512
513
514
515;; routine to sum up all descriptions with same payee and to store account guid and also non uppercase description
516 (define (total-payee-hash-add! payee-hash payee amount payee-account-guid-hash guids+description )
517 (begin
518 (hash-set! payee-hash payee (gnc-numeric-add amount (hash-ref payee-hash payee (gnc-numeric-zero)) GNC-DENOM-AUTO GNC-RND-ROUND))
519 (hash-set! payee-account-guid-hash payee guids+description )))
520
521(define (get-primary-key transaction)
522 (let* (
523 ;;
524 (thekey (car transaction))
525 (endprimary (string-contains thekey "#Yw;"))
526 (primary (if (< 0 endprimary)
527 (string-copy thekey 0 endprimary)
528 " ")) ;default
529 )
530 primary
531 )
532 )
533
534(define (get-secondary-key transaction)
535 (let* (
536 (thekey (car transaction))
537 (startsecond (string-contains thekey "#Yw;"))
538 (endsecond (string-contains thekey "#Yx;"))
539 (secondary (if (< 4 (- endsecond startsecond))
540 (string-copy thekey (+ 4 startsecond) endsecond)
541 " " ));default
542 )
543 secondary
544 )
545 )
546(define (get-date-key-tm the-key)
547 (let* (
548 (date (if (< 7 (string-length the-key))
549 the-key
550 "20000114" ;default date
551 ))
552
553 (year (string->number (string-copy date 0 4)))
554 (month (string->number (string-copy date 4 6)))
555 (day (string->number (string-copy date 6 8)))
556 ; (tm2 (strptime "%Y %m %d" (string-append (string-copy date 0 4)
557 ; " " (string-copy date 4 6) " " (string-copy date 6 8) )))
558 (tm today-tm)
559 )
560 (set-tm:year tm (- year 1900))
561 (set-tm:mon tm (- month 1))
562 (set-tm:mday tm day)
563 tm
564 )
565 )
566(define (get-date-key-tp the-key)
567 (gnc:date->timepair (get-date-key-tm the-key))
568 )
569(define (get-date-tm transaction)
570 (let* (
571 (thekey (car transaction))
572 (startdate (string-contains thekey "#Yx;"))
573 (enddate (string-contains thekey "#Yy;"))
574 (date (if (< 11 (- enddate startdate))
575 (string-copy thekey (+ 4 startdate) enddate)
576 "20000114" ;default date
577 ))
578
579 (year (string->number (string-copy date 0 4)))
580 (month (string->number (string-copy date 4 6)))
581 (day (string->number (string-copy date 6 8)))
582 (tm today-tm)
583 )
584 (set-tm:year tm (- year 1900))
585 (set-tm:mon tm (- month 1))
586 (set-tm:mday tm day)
587 tm
588 )
589 )
590(define (get-date-tp transaction)
591 (gnc:date->timepair (get-date-tm transaction))
592 )
593(define (get-currency-type transaction)
594 (let* (
595 (thekey (car transaction))
596 (startcurr (string-contains thekey "#Zu;"))
597 (currency-type-str (if (< (+ startcurr 4) (string-length thekey))
598 (string-copy thekey (+ startcurr 4))
599 ;(string-take-right thekey (+ startcurr 4))
600 " ")))
601 currency-type-str)
602)
603(define (get-memo transaction)
604 (let* (
605 (thekey (car transaction))
606 (endmemo (string-contains thekey "#Zv;"))
607 (startmem (string-contains thekey "#Zw;"))
608 (memo (if (< 4 (- endmemo startmem))
609 (string-copy thekey (+ startmem 4) endmemo)
610 " ")))
611 memo)
612)
613
614(define (get-reverse-sign? transaction)
615 (let* (
616 (thekey (car transaction))
617 (end (string-contains thekey "#Zu;"))
618 (start (string-contains thekey "#Zv;"))
619 (rev-sign (if (< 4 (- end start))
620 #t
621 #f)))
622 rev-sign)
623)
624
625(define (get-description transaction)
626 (let* (
627 (thekey (car transaction))
628 (startdescrip (string-contains thekey "#Yy;"))
629 (enddescrip (string-contains thekey "#Yz;"))
630 (description (if (< 4 (- enddescrip startdescrip))
631 (string-copy thekey (+ 4 startdescrip) enddescrip)
632 " ")))
633 description)
634 )
635
636(define (get-description-verbatim row)
637;; the actual description entered by user - removes problems with upper and lower case
638 (let* (
639 (descript (caddr (array-ref guid-array row 0))))
640 (if descript
641 descript
642 "")))
643(define (get-namecode transaction)
644 (let* (
645 (thekey (car transaction))
646 (startnamcode (string-contains thekey "#Yz;"))
647 (endnamcode (string-contains thekey "#Zy;"))
648 (namcode (if (< 4 (- endnamcode startnamcode))
649 (string-copy thekey (+ 4 startnamcode) endnamcode)
650 " ")))
651 namcode)
652 )
653
654(define (get-account-code transaction)
655 (let* (
656 (thekey (car transaction))
657 (startcod (string-contains thekey "#Zy;"))
658 (endothercod (string-contains thekey "#Zx;"))
659 (acctcod (if (< 4 (- endothercod startcod))
660 (string-copy thekey (+ startcod 4) endothercod)
661 " ")))
662 acctcod)
663 )
664
665
666(define (get-other-name transaction)
667 (let* (
668 (thekey (car transaction))
669 (endacctname (string-contains thekey "#Zx;"))
670 (endothernam (string-contains thekey "#Zw;"))
671 (othernam (if (< 4 (- endothernam endacctname))
672 (string-copy thekey (+ endacctname 4) endothernam)
673 " ")))
674 othernam)
675 )
676
677(define (get-accountname-from-sort thekey transaction)
678 (let ((start-account (string-contains thekey "#Yv;")))
679 (if start-account
680 (if (< (+ 4 start-account) (string-length thekey) )
681 (string-append (get-account-code transaction) (substring thekey (+ 4 (string-contains thekey "#Yv;"))))
682 " ")
683 thekey)
684 ))
685
686(define (get-accountguid transaction)
687;; we stored (account-guid (gncAccountGetGUID account))
688 (let* ( (row (get-row-in-array transaction))
689 (accountguid (cadr (array-ref guid-array row 0))))
690 (if accountguid
691 accountguid
692 "")))
693
694(define (get-transguid row column)
695;; we stored (account-guid (gncAccountGetGUID account))
696 (let* (
697 (transguid (if (array-ref guid-array row column)
698 (car (array-ref guid-array row column))
699 "")))
700 transguid
701 ))
702
703(define (get-split-value-numer transaction)
704 (let (
705 (split-value-comp (cdr transaction))
706 ; (split-value-comp (gnc:make-gnc-numeric 12 1))
707 )
708 split-value-comp)
709)
710
711
712(define (get-row-in-array transaction)
713 (cdr transaction)
714)
715(define (get-array-value-num-base transaction) ;note values are scaled when stored in array
716 (let* ( (row (get-row-in-array transaction))
717 (split-value-ar
718 (array-ref amounts-array row 1)) ;column is 1 since for base period
719 (value (if (gnc:gnc-monetary? split-value-ar)
720 (gnc:gnc-numeric-num (gnc:gnc-monetary-amount split-value-ar))
721 0.0)))
722 value
723 )
724)
725
726(define (get-monetary key column) ;note values are scaled when stored in array
727 (let* ( (row (get-row-in-array key))
728 (split-value-ar
729 (array-ref amounts-array row column))
730 (value (if (gnc:gnc-monetary? split-value-ar)
731 split-value-ar
732 ;(gnc:make-gnc-monetary report-currency (gnc:make-gnc-numeric 2 1))))
733 (gnc:make-gnc-monetary
734 (hash-ref currency-lookup-hash (get-currency-type key))
735 split-value-ar)))
736 )
737 value
738))
739
740
741
742
743
744(define (gnc:comp-register-guid type guid)
745 (gnc-build-url URL-TYPE-REGISTER (string-append type guid) ""))
746
747(define (gnc-comp:transaction-anchor-text trans)
748 (gnc:comp-register-guid "trans-guid=" (gncTransGetGUID trans)))
749
750 (define (get-gnc:comp-transaction-anchor-text row column)
751 (gnc:comp-register-guid "trans-guid=" (get-transguid row column)))
752
753(define (gnc:comp-html-transaction-anchor row column text)
754 (gnc:make-html-text (gnc:html-markup-anchor
755 (get-gnc:comp-transaction-anchor-text row column)
756 text)))
757
758(define (get-gnc:account-anchor-text split-trans)
759 ;(gnc:register-guid "acct-guid=" (gncAccountGetGUID acct)))
760 (let* ( (acctguid (get-accountguid split-trans)))
761 (if acctguid
762 (gnc:comp-register-guid "acct-guid=" acctguid)
763 "")))
764
765
766;; for imbalance and orphan accounts
767(define (gnc:accounts-imbalance-or-orphan start-date-tp end-date-tp)
768;; returns list of accounts starting with the letters "imbalanc" which do not have a zero (0)
769;; change in the balance between the start date and the end date
770 (let* (
771 (all-accounts (gnc-account-get-descendants-sorted
772 (gnc-get-current-root-account)))
773 )
774 (filter (lambda (acct)
775 (if (or (string-prefix-ci? "imbalance" (gnc-account-get-full-name acct))
776 (string-prefix-ci? "orphan" (gnc-account-get-full-name acct)))
777 ;; check if the change in balance from the 'from' date to the 'to' date.
778 ;; is 0
779 (if (equal? (gnc-numeric-zero) (gnc:account-get-balance-interval acct start-date-tp end-date-tp #f))
780 #f
781 #t)
782 #f))
783 all-accounts)
784))
785;; end for imbalance
786
787
788;; for consolidating
789(define (sortkeys list-thekeys var-p var-s comp-p1 comp-p2 comp-s1 comp-s2)(sort list-thekeys
790 ;1 sort by primary key and secondary key
791 ;2 sort by primary key and amount
792 ;3 sort by amount and secondary key
793 ;4 sort by amount and amount
794 ; will do 3rd sort on description
795
796
797 (lambda (x y)
798 (let ( (primary-x (var-p x))
799 (primary-y (var-p y))
800 (secondary-x (var-s x))
801 (secondary-y (var-s y)) )
802 (if (not (comp-p1 primary-x primary-y ))
803 (comp-p2 primary-x primary-y)
804 (if (not (comp-s1 secondary-x secondary-y))
805 (comp-s2 secondary-x secondary-y )
806 (string-ci<=? (get-description x) (get-description y)))
807 ))
808 )
809
810 ))
811
812;; The option-values of the sorting key multichoice option, for
813;; which a subtotal should be enabled.
814(define comp-subtotal-enabled '(account-name
815 account-code
816 corresponding-acc-name
817 corresponding-acc-code))
818
819(define (comp-split-account-full-name-same-p a b)
820 (equal? a b))
821
822(define (comp-split-account-code-same-p a b)
823 (equal? a b))
824
825(define (comp-split-same-corr-account-full-name-p a b)
826 (equal? a b))
827
828(define (comp-split-same-corr-account-code-p a b)
829 (equal? a b))
830
831(define (comp-timepair-same-year tp-a tp-b)
832 (= (gnc:timepair-get-year tp-a)
833 (gnc:timepair-get-year tp-b)))
834
835(define (comp-timepair-same-quarter tp-a tp-b)
836 (and (comp-timepair-same-year tp-a tp-b)
837 (= (gnc:timepair-get-quarter tp-a)
838 (gnc:timepair-get-quarter tp-b))))
839
840(define (comp-timepair-same-month tp-a tp-b)
841 (and (comp-timepair-same-year tp-a tp-b)
842 (= (gnc:timepair-get-month tp-a)
843 (gnc:timepair-get-month tp-b))))
844
845(define (comp-timepair-same-week tp-a tp-b)
846 (and (comp-timepair-same-year tp-a tp-b)
847 (= (gnc:timepair-get-week tp-a)
848 (gnc:timepair-get-week tp-b))))
849
850(define (comp-split-same-week-p a b)
851 (let ((tp-a (get-date-key-tp a))
852 (tp-b (get-date-key-tp b)))
853 (comp-timepair-same-week tp-a tp-b)))
854
855(define (comp-split-same-month-p a b)
856 (let ((tp-a (get-date-key-tp a))
857 (tp-b (get-date-key-tp b)))
858 (comp-timepair-same-month tp-a tp-b)))
859
860(define (comp-split-same-quarter-p a b)
861 (let ((tp-a (get-date-key-tp a))
862 (tp-b (get-date-key-tp b)))
863 (comp-timepair-same-quarter tp-a tp-b)))
864
865(define (comp-split-same-year-p a b)
866 (let ((tp-a (get-date-key-tp a))
867 (tp-b (get-date-key-tp b)))
868 (comp-timepair-same-year tp-a tp-b)))
869;;
870
871(define (comp-set-last-row-style! table tag . rest)
872 (let ((arg-list
873 (cons table
874 (cons (- (gnc:html-table-num-rows table) 1)
875 (cons tag rest)))))
876 (apply gnc:html-table-set-row-style! arg-list)))
877
878(define (comp-add-subheading-row data table width subheading-style)
879 (let ((heading-cell (gnc:make-html-table-cell data)))
880 (gnc:html-table-cell-set-colspan! heading-cell width)
881 (gnc:html-table-append-row/markup!
882 table
883 subheading-style
884 (list heading-cell))))
885
886;; display an account name depending on the options the user has set
887(define (comp-account-namestring account show-account-code show-account-name show-account-full-name)
888 ;;# on multi-line splits we can get an empty ('()) account
889 (if (null? account)
890 (_ "Split Transaction")
891 (string-append
892 ;; display account code?
893 (if show-account-code
894 (string-append (xaccAccountGetCode account) " ")
895 "")
896 ;; display account name?
897 (if show-account-name
898 ;; display full account name?
899 (if show-account-full-name
900 (gnc-account-get-full-name account)
901 (xaccAccountGetName account))
902 ""))))
903
904;; render an account subheading - column-vector determines what is displayed
905(define (comp-render-account-subheading
906 split-trans the-key table width subheading-style column-vector)
907 (let ((accountname (get-accountname-from-sort the-key split-trans)))
908 (comp-add-subheading-row (gnc:make-html-text
909 (gnc:html-markup-anchor
910 (get-gnc:account-anchor-text split-trans)
911 accountname) )
912 table width subheading-style)))
913
914(define (comp-render-corresponding-account-subheading
915 split-trans the-key table width subheading-style column-vector)
916 (let ((accountname the-key))
917 (comp-add-subheading-row (gnc:make-html-text
918 (gnc:html-markup-anchor
919 (if (not (null? split-trans))
920 (get-gnc:account-anchor-text split-trans)
921 "")
922 accountname) )
923 table width subheading-style)))
924
925(define (comp-render-week-subheading split-trans the-key table width subheading-style column-vector)
926 (comp-add-subheading-row (gnc:date-get-week-year-string
927 (get-date-tm split-trans))
928 table width subheading-style))
929
930(define (comp-render-month-subheading split-trans the-key table width subheading-style column-vector)
931 (comp-add-subheading-row (gnc:date-get-month-year-string
932 (get-date-tm split-trans))
933 table width subheading-style))
934
935(define (comp-render-quarter-subheading split-trans the-key table width subheading-style column-vector)
936 (comp-add-subheading-row (gnc:date-get-quarter-year-string
937 (get-date-tm split-trans))
938 table width subheading-style))
939
940(define (comp-render-year-subheading split-trans the-key table width subheading-style column-vector)
941 (comp-add-subheading-row (gnc:date-get-year-string
942 (get-date-tm split-trans))
943 table width subheading-style))
944
945
946(define (comp-add-subtotal-row table width subtotal-string subtotal-collector subtotal-collector-hash
947 subtotal-style export?)
948 (let ((currency-totals (subtotal-collector
949 'format gnc:make-gnc-monetary #f))
950 (blanks (gnc:make-html-table-cell/size 1 (- width 1) #f))
951 (row-contents '())
952 (the-currency 1))
953
954 (while (< the-currency currency-type-num)
955 (let ((currency (hash-ref currency-lookup-hash (number->string the-currency)))
956 (col 1)
957 (count-spaces 1))
958 (if (= the-currency 1)
959 (addto! row-contents
960 (gnc:make-html-table-cell/markup "total-label-cell" subtotal-string))
961 (addto! row-contents
962 (gnc:make-html-table-cell/markup "total-label-cell" " " )))
963 (set! count-spaces (+ count-spaces 1))
964 ; I can't figure out how to get blanks so brute force
965 (while (< count-spaces columns-headings )
966 (addto! row-contents
967 (gnc:make-html-table-cell/markup
968 "total-number-cell"
969 " " ))
970 (set! count-spaces (+ 1 count-spaces))
971 )
972 (while (<= col last-column)
973 (addto! row-contents
974 (gnc:make-html-table-cell/markup
975 "total-number-cell" (hash-ref subtotal-collector-hash
976 (string-append (number->string col) "#Vv;" (number->string the-currency))
977 (gnc:make-gnc-monetary currency (gnc-numeric-zero)))))
978 (set! col (+ col 1))
979 )
980 (set! the-currency (+ the-currency 1))
981 )
982 (gnc:html-table-append-row/markup! table subtotal-style
983 (reverse row-contents))
984 (set! row-contents '()))
985 ))
986
987
988(define (comp-total-string str) (string-append (_ "Total For ") str))
989
990(define (comp-render-account-subtotal
991 table width split the-key total-collector total-collector-hash subtotal-style column-vector export?)
992 (comp-add-subtotal-row table width
993 (total-string (get-accountname-from-sort the-key split))
994 total-collector total-collector-hash subtotal-style export?))
995
996(define (comp-render-corresponding-account-subtotal
997 table width split the-key total-collector total-collector-hash subtotal-style column-vector export?)
998 (comp-add-subtotal-row table width
999 (total-string the-key)
1000 total-collector total-collector-hash subtotal-style export?))
1001
1002(define (comp-render-week-subtotal
1003 table width split the-key total-collector total-collector-hash subtotal-style column-vector export?)
1004 (let ((tm (get-date-tm split)))
1005 (comp-add-subtotal-row table width
1006 (total-string (gnc:date-get-week-year-string tm))
1007 total-collector total-collector-hash subtotal-style export?)))
1008
1009(define (comp-render-month-subtotal
1010 table width split the-key total-collector total-collector-hash subtotal-style column-vector export?)
1011 (let ((tm (get-date-tm split)))
1012 (comp-add-subtotal-row table width
1013 (total-string (gnc:date-get-month-year-string tm))
1014 total-collector total-collector-hash subtotal-style export?)))
1015
1016
1017(define (comp-render-quarter-subtotal
1018 table width split the-key total-collector total-collector-hash subtotal-style column-vector export?)
1019 (let ((tm (get-date-tm split)))
1020 (comp-add-subtotal-row table width
1021 (total-string (gnc:date-get-quarter-year-string tm))
1022 total-collector total-collector-hash subtotal-style export?)))
1023
1024(define (comp-render-year-subtotal
1025 table width split the-key total-collector total-collector-hash subtotal-style column-vector export?)
1026 (let ((tm (get-date-tm split)))
1027 (comp-add-subtotal-row table width
1028 (total-string (strftime "%Y" tm))
1029 total-collector total-collector-hash subtotal-style export?)))
1030
1031
1032(define (comp-render-grand-total
1033 table width total-collector total-collector-hash export?)
1034 (comp-add-subtotal-row table width
1035 (_ "Grand Total")
1036 total-collector total-collector-hash def:grand-total-style export?))
1037
1038;; end section for consolidating
1039
1040
1041;;following part of original transaction.scm
1042;; The option-values of the sorting key multichoice option, for
1043;; which a subtotal should be enabled.
1044(define subtotal-enabled '(account-name
1045 account-code
1046 corresponding-acc-name
1047 corresponding-acc-code))
1048
1049(define (split-account-full-name-same-p a b)
1050 (= (xaccSplitCompareAccountFullNames a b) 0))
1051
1052(define (split-account-code-same-p a b)
1053 (= (xaccSplitCompareAccountCodes a b) 0))
1054
1055(define (split-same-corr-account-full-name-p a b)
1056 (= (xaccSplitCompareOtherAccountFullNames a b) 0))
1057
1058(define (split-same-corr-account-code-p a b)
1059 (= (xaccSplitCompareOtherAccountCodes a b) 0))
1060
1061(define (timepair-same-year tp-a tp-b)
1062 (= (gnc:timepair-get-year tp-a)
1063 (gnc:timepair-get-year tp-b)))
1064
1065(define (timepair-same-quarter tp-a tp-b)
1066 (and (timepair-same-year tp-a tp-b)
1067 (= (gnc:timepair-get-quarter tp-a)
1068 (gnc:timepair-get-quarter tp-b))))
1069
1070(define (timepair-same-month tp-a tp-b)
1071 (and (timepair-same-year tp-a tp-b)
1072 (= (gnc:timepair-get-month tp-a)
1073 (gnc:timepair-get-month tp-b))))
1074
1075(define (timepair-same-week tp-a tp-b)
1076 (and (timepair-same-year tp-a tp-b)
1077 (= (gnc:timepair-get-week tp-a)
1078 (gnc:timepair-get-week tp-b))))
1079
1080(define (split-same-week-p a b)
1081 (let ((tp-a (gnc-transaction-get-date-posted (xaccSplitGetParent a)))
1082 (tp-b (gnc-transaction-get-date-posted (xaccSplitGetParent b))))
1083 (timepair-same-week tp-a tp-b)))
1084
1085(define (split-same-month-p a b)
1086 (let ((tp-a (gnc-transaction-get-date-posted (xaccSplitGetParent a)))
1087 (tp-b (gnc-transaction-get-date-posted (xaccSplitGetParent b))))
1088 (timepair-same-month tp-a tp-b)))
1089
1090(define (split-same-quarter-p a b)
1091 (let ((tp-a (gnc-transaction-get-date-posted (xaccSplitGetParent a)))
1092 (tp-b (gnc-transaction-get-date-posted (xaccSplitGetParent b))))
1093 (timepair-same-quarter tp-a tp-b)))
1094
1095(define (split-same-year-p a b)
1096 (let ((tp-a (gnc-transaction-get-date-posted (xaccSplitGetParent a)))
1097 (tp-b (gnc-transaction-get-date-posted (xaccSplitGetParent b))))
1098 (timepair-same-year tp-a tp-b)))
1099
1100(define (set-last-row-style! table tag . rest)
1101 (let ((arg-list
1102 (cons table
1103 (cons (- (gnc:html-table-num-rows table) 1)
1104 (cons tag rest)))))
1105 (apply gnc:html-table-set-row-style! arg-list)))
1106
1107
1108;; display an account name depending on the options the user has set
1109(define (account-namestring account show-account-code show-account-name show-account-full-name)
1110 ;;# on multi-line splits we can get an empty ('()) account
1111 (if (null? account)
1112 (_ "Split Transaction")
1113 (string-append
1114 ;; display account code?
1115 (if show-account-code
1116 (string-append (xaccAccountGetCode account) " ")
1117 "")
1118 ;; display account name?
1119 (if show-account-name
1120 ;; display full account name?
1121 (if show-account-full-name
1122 (gnc-account-get-full-name account)
1123 (xaccAccountGetName account))
1124 ""))))
1125
1126
1127(define (total-string str) (string-append (_ "Total For ") str))
1128
1129
1130(define account-types-to-reverse-assoc-list
1131 (list (cons 'none '())
1132 (cons 'income-expense
1133 (list ACCT-TYPE-INCOME ACCT-TYPE-EXPENSE))
1134 (cons 'credit-accounts
1135 (list ACCT-TYPE-LIABILITY ACCT-TYPE-PAYABLE ACCT-TYPE-EQUITY
1136 ACCT-TYPE-CREDIT ACCT-TYPE-INCOME))))
1137
1138(define (get-account-types-to-reverse options)
1139 (cdr (assq (gnc:option-value
1140 (gnc:lookup-option options
1141 pagename-display
1142 (N_ "Sign Reverses")))
1143 account-types-to-reverse-assoc-list)))
1144
1145(define (used-date columns-used)
1146 (vector-ref columns-used 0))
1147(define (used-reconciled-date columns-used)
1148 (vector-ref columns-used 1))
1149(define (used-num columns-used)
1150 (vector-ref columns-used 2))
1151(define (used-description columns-used)
1152 (vector-ref columns-used 3))
1153(define (used-account-name columns-used)
1154 (vector-ref columns-used 4))
1155(define (used-other-account-name columns-used)
1156 (vector-ref columns-used 5))
1157(define (used-shares columns-used)
1158 (vector-ref columns-used 6))
1159(define (used-price columns-used)
1160 (vector-ref columns-used 7))
1161(define (used-amount-single columns-used)
1162 (vector-ref columns-used 8))
1163(define (used-amount-double-positive columns-used)
1164 (vector-ref columns-used 9))
1165(define (used-amount-double-negative columns-used)
1166 (vector-ref columns-used 10))
1167(define (used-running-balance columns-used)
1168 (vector-ref columns-used 11))
1169(define (used-account-full-name columns-used)
1170 (vector-ref columns-used 12))
1171(define (used-memo columns-used)
1172 (vector-ref columns-used 13))
1173(define (used-account-code columns-used)
1174 (vector-ref columns-used 14))
1175(define (used-other-account-code columns-used)
1176 (vector-ref columns-used 15))
1177(define (used-other-account-full-name columns-used)
1178 (vector-ref columns-used 16))
1179(define (used-sort-account-code columns-used)
1180 (vector-ref columns-used 17))
1181(define (used-sort-account-full-name columns-used)
1182 (vector-ref columns-used 18))
1183(define (used-notes columns-used)
1184 (vector-ref columns-used 19))
1185
1186(define columns-used-size 20)
1187
1188(define (num-columns-required columns-used) ; this routine is called but results don't seem to be used
1189 (do ((i 0 (+ i 1))
1190 (col-req 0 col-req))
1191 ((>= i columns-used-size) col-req)
1192 ; If column toggle is true, increase column count. But attention:
1193 ; some toggles only change the meaning of another toggle. Don't count these modifier toggles
1194 (if (and (not (= i 12)) ; Skip Account Full Name toggle - modifies Account Name column
1195 (not (= i 16)) ; Skip Other Account Full Name toggle - modifies Other Account Name column
1196 (not (= i 17)) ; Skip Sort Account Code - modifies Account Name subheading
1197 (not (= i 18)) ; Skip Sort Account Full Name - modifies Account Name subheading
1198 (not (= i 19)) ; Skip Note toggle - modifies Memo column
1199 (vector-ref columns-used i))
1200 (set! col-req (+ col-req 1)))
1201 ; Account Code and Account Name share one column so if both were ticked the
1202 ; the check above would have set up one column too much. The check below
1203 ; will compensate these again.
1204 (if (or (and (= i 14) (vector-ref columns-used 14) (vector-ref columns-used 4)) ; Account Code and Name
1205 (and (= i 15) (vector-ref columns-used 15) (vector-ref columns-used 5))) ; Other Account Code and Name
1206 (set! col-req (- col-req 1)))
1207 ))
1208
1209(define (build-column-used options)
1210 (define (opt-val section name)
1211 (gnc:option-value
1212 (gnc:lookup-option options section name)))
1213 (let ((column-list (make-vector columns-used-size #f)))
1214 (if (opt-val pagename-display (N_ "Description"))
1215 (vector-set! column-list 3 #t))
1216 (if (opt-val pagename-display (N_ "Account Name"))
1217 (vector-set! column-list 4 #t))
1218 (if (opt-val pagename-display (N_ "Other Account Name"))
1219 (vector-set! column-list 5 #t))
1220 ; (if (opt-val pagename-display (N_ "Shares"))
1221 ; (vector-set! column-list 6 #t))
1222; (if (opt-val pagename-display (N_ "Price"))
1223; (vector-set! column-list 7 #t))
1224 (vector-set! column-list 8 #t) ; set as always single
1225 ; (if (opt-val pagename-display (N_ "Running Balance"))
1226 ; (vector-set! column-list 11 #t))
1227 (if (opt-val pagename-display (N_ "Use Full Account Name"))
1228 (vector-set! column-list 12 #t))
1229 (if (opt-val pagename-display (N_ "Memo"))
1230 (vector-set! column-list 13 #t))
1231 (if (opt-val pagename-display (N_ "Account Code"))
1232 (vector-set! column-list 14 #t))
1233 (if (opt-val pagename-display (N_ "Other Account Code"))
1234 (vector-set! column-list 15 #t))
1235 (if (opt-val pagename-display (N_ "Use Full Other Account Name"))
1236 (vector-set! column-list 16 #t))
1237 (if (opt-val pagename-sorting (N_ "Show Account Code"))
1238 (vector-set! column-list 17 #t))
1239 (if (opt-val pagename-sorting (N_ "Show Full Account Name"))
1240 (vector-set! column-list 18 #t))
1241 (if (opt-val pagename-display (N_ "Notes"))
1242 (vector-set! column-list 19 #t))
1243 column-list))
1244
1245(define (make-heading-list column-vector options)
1246 (let ((heading-list '()))
1247 (if (used-description column-vector)
1248 (addto! heading-list (_ "Description")))
1249 (if (used-memo column-vector)
1250 (if (used-notes column-vector)
1251 (addto! heading-list (string-append (_ "Memo") "/" (_ "Notes")))
1252 (addto! heading-list (_ "Memo"))))
1253 (if (or (used-account-name column-vector) (used-account-code column-vector))
1254 (addto! heading-list (_ "Account")))
1255 (if (or (used-other-account-name column-vector) (used-other-account-code column-vector))
1256 (addto! heading-list (_ "Transfer from/to")))
1257 (if (used-shares column-vector)
1258 (addto! heading-list (_ "Shares")))
1259 (if (used-price column-vector)
1260 (addto! heading-list (_ "Price")))
1261 (if (used-amount-single column-vector)
1262 ; (addto! heading-list (_ "Amount")))
1263 (addto! heading-list
1264 (gnc:make-html-table-cell/markup
1265 "column-heading-center"
1266 (array-ref amounts-array
1267 0 1
1268 ))))
1269 ;; FIXME: Proper labels: what?
1270 (if (used-amount-double-positive column-vector)
1271 (addto! heading-list (_ "Debit")))
1272 (if (used-amount-double-negative column-vector)
1273 (addto! heading-list (_ "Credit")))
1274 (if (used-running-balance column-vector)
1275 (addto! heading-list (_ "Balance")))
1276 (set! columns-headings (length heading-list))
1277 ;(if compare?
1278 (let* ( (col 2))
1279 (while (<= col last-column)
1280 (addto! heading-list
1281 (gnc:make-html-table-cell/markup
1282 "column-heading-center"
1283 (array-ref amounts-array
1284 0 col
1285 )))
1286 (set! col (+ col 1))))
1287; )
1288 (reverse heading-list)))
1289;;
1290
1291;;
1292(define (make-heading-days table row-style)
1293 (let ((heading-list '())
1294 (col 2))
1295 (addto! heading-list
1296 (gnc:make-html-text (gnc:html-markup-b
1297 (_ text-number-days))))
1298 (while (< col columns-headings)
1299 (addto! heading-list
1300 (_ " "))
1301 (set! col (+ col 1)))
1302
1303 (let* ( (col 1))
1304 (while (<= col last-column)
1305 (addto! heading-list
1306 (gnc:make-html-table-cell/markup
1307 "column-heading-right"
1308 (if (and show-average? (= col 3))
1309 ""
1310 (display-num-days
1311 (array-ref amounts-array
1312 1 col
1313 )))))
1314 (set! col (+ col 1))))
1315 (gnc:html-table-append-row! table
1316 (reverse heading-list)))
1317)
1318
1319(define (make-heading-scale table row-style)
1320 (let ((heading-list '())
1321 (col 2))
1322 (addto! heading-list
1323 (gnc:make-html-text (gnc:html-markup-b
1324 (if compare-scale-automatically?
1325
1326 (_ " Scaled to:")
1327 (_ " Scaled by:")))))
1328 (while (< col columns-headings)
1329 (addto! heading-list
1330 (_ " "))
1331 (set! col (+ col 1)))
1332 (addto! heading-list
1333 ;(gnc:make-html-text (gnc:html-markup-b
1334 (gnc:make-html-table-cell/markup
1335 "column-heading-right"
1336 (if compare-scale-automatically?
1337 (_ (number->string compare-scale-to-val))
1338 (_ (string-append (vector-ref (cdr (assq scale-op-val scale-num)) 1) (number->string scale-num-val))))))
1339
1340 (let* ( (col 2))
1341 (while (<= col last-column)
1342 (addto! heading-list
1343 (gnc:make-html-table-cell/markup
1344 "column-heading-right"
1345 (if (and show-average? (or (= col 3) (= col 4)))
1346 ""
1347 (if compare-scale-automatically?
1348 (_ (number->string compare-scale-to-val))
1349 (_ (string-append (vector-ref (cdr (assq scale-op-val2 scale-num)) 1) (number->string scale-num-val2)))))))
1350 ; (_ (number->string scale-num-val2)))))
1351 (set! col (+ col 1))))
1352 (gnc:html-table-append-row! table
1353 (reverse heading-list)))
1354)
1355
1356;; following section for composite/consolidate transactions
1357(define (add-split-row-comp table split-trans column-vector options
1358 row-style account-types-to-reverse transaction-row?)
1359
1360 (define (opt-val section name)
1361 (gnc:option-value
1362 (gnc:lookup-option options section name)))
1363
1364 (let* ((row-contents '())
1365 (dummy (gnc:debug "split-trans is originally" split-trans))
1366 (report-currency (hash-ref currency-lookup-hash (get-currency-type split-trans)))
1367 (currency-frac (gnc-commodity-get-fraction report-currency))
1368 (row-in-array (get-row-in-array split-trans))
1369 (split-value-ar (get-monetary split-trans 1))
1370 (split-value-ar-coll (if (get-reverse-sign? split-trans)
1371 (gnc:make-gnc-monetary report-currency (gnc-numeric-neg (gnc:gnc-monetary-amount split-value-ar)))
1372 split-value-ar))
1373 (found? #t)
1374 (col 1))
1375
1376 (if do-findamount?
1377 (begin
1378 (set! found? #f)
1379 (while (<= col last-column)
1380 (if (find-monetary? (get-monetary split-trans col))
1381 ;(if (>= (gnc:gnc-numeric-num (gnc:gnc-monetary-amount (get-monetary split-trans col))) find-min )
1382 (set! found? #t))
1383 (set! col (+ col 1)))
1384 ))
1385
1386 (if (used-description column-vector)
1387 (addto! row-contents
1388 (if transaction-row?
1389 (gnc:make-html-table-cell/markup "text-cell"
1390 (if description-titlecase?
1391 (string-titlecase (get-description-verbatim row-in-array))
1392 (get-description-verbatim row-in-array)))
1393 " ")))
1394
1395 (if (used-memo column-vector)
1396 (addto! row-contents
1397 (get-memo split-trans)
1398 ))
1399
1400 (if (or (used-account-name column-vector) (used-account-code column-vector))
1401 (addto! row-contents (get-namecode split-trans)))
1402
1403 (if (or (used-other-account-name column-vector) (used-other-account-code column-vector))
1404 (addto! row-contents (get-other-name split-trans)))
1405
1406 (if (used-shares column-vector)
1407 (addto! row-contents " "))
1408
1409 (if (used-price column-vector)
1410 (addto!
1411 row-contents
1412 " "))
1413
1414 (if (used-amount-single column-vector);; always true
1415
1416 (let* ( (colmn 1))
1417 (while (<= colmn last-column)
1418 (addto! row-contents
1419 ; the amount is printed here
1420 (gnc:make-html-table-cell/markup "number-cell"
1421 (if (and show-average? (= colmn 4))
1422 ""
1423 (gnc:comp-html-transaction-anchor
1424 row-in-array colmn
1425 (get-monetary split-trans colmn)))))
1426 (set! colmn (+ colmn 1))))
1427 )
1428 (if found?
1429 (gnc:html-table-append-row/markup! table row-style
1430 (reverse row-contents)))
1431 split-value-ar-coll))
1432
1433;end section -consolite
1434
1435(define date-sorting-types (list 'date 'exact-time 'register-order))
1436
1437(define (trep-options-generator)
1438 (define gnc:*transaction-report-options* (gnc:new-options))
1439 (define (gnc:register-trep-option new-option)
1440 (gnc:register-option gnc:*transaction-report-options* new-option))
1441
1442
1443
1444
1445
1446
1447
1448 ;; General options
1449
1450;; To add gnctimeperiod-utilities comment out old period over which to report income
1451;; and add section 3
1452;;
1453
1454;; (gnc:options-add-date-interval!
1455 ;; gnc:*transaction-report-options*
1456 ;; pagename-general (N_ "Start Date") (N_ "End Date") "a")
1457;;
1458
1459;;
1460 ;; step 3 of 4 to add gnctimeperiod-utilities
1461 ;add select custom date or a specific period
1462 ; changed add-option to gnc:register-trep-option
1463(let ((periodoptions gnc:*transaction-report-options*))
1464 (gnc:register-trep-option
1465 (gnc:make-multichoice-callback-option
1466 ; (gnc:make-multichoice-option
1467 the_tab (N_ text-whichperiod)
1468 "ca" (N_ "Select which time period to use")
1469 'last
1470;; gnc:list-datechoices
1471;; ))
1472 gnc:list-datechoices #f
1473 (lambda (x)
1474 (gnc-option-db-set-option-selectable-by-name
1475 periodoptions the_tab (N_ text-pick-year)
1476 (if (equal? x 'customdates) #f #t))
1477 (gnc-option-db-set-option-selectable-by-name
1478 periodoptions the_tab (N_ text-period)
1479 (if (equal? x 'period) #t #f))
1480 (gnc-option-db-set-option-selectable-by-name
1481 periodoptions the_tab (N_ text-last)
1482 (if (equal? x 'last) #t #f))
1483 (gnc-option-db-set-option-selectable-by-name
1484 periodoptions the_tab (N_ text-month)
1485 (if (equal? x 'month) #t #f))
1486 ))
1487 ))
1488 ; add custom date
1489 (gnc:options-add-date-interval!
1490 gnc:*transaction-report-options* the_tab
1491 custom-from-date custom-to-date "cb")
1492
1493 ; add pick year for specific period
1494 (gnc:register-trep-option
1495 (gnc:make-multichoice-option the_tab (N_ text-pick-year)
1496 "ce" (N_ "Pick the year for report") 'this-yr
1497 gnc:list-years
1498 ))
1499 ; add pick specific period
1500 (gnc:register-trep-option
1501 (gnc:make-multichoice-option the_tab (N_ text-period)
1502 "cf" (N_ "Pick portion of the year for report") 'fullyear
1503 gnc:list-periods
1504 ))
1505 ; add pick specific last XX
1506 (gnc:register-trep-option
1507 (gnc:make-multichoice-option the_tab (N_ text-last)
1508 "cg" (N_ "Pick portion of the year for report") 'lastmonth
1509 gnc:list-lasts
1510 ))
1511 ; add pick specific month
1512 (gnc:register-trep-option
1513 (gnc:make-multichoice-option the_tab (N_ text-month)
1514 "ch" (N_ "Pick which month for report") '4
1515 gnc:list-months
1516 ))
1517 ; add pick for multiply or divide
1518 (gnc:register-trep-option
1519 (gnc:make-multichoice-option the_tab (N_ "Scale Results")
1520 "ci" (N_ "Scale the results - multiply or divide by scale factor") '*
1521 gnc:list-operands
1522 ))
1523 ; add where number for multiply or divide can be changed
1524 (gnc:register-trep-option
1525 (gnc:make-number-range-option the_tab (N_ "Scale Number Option")
1526 "cj" (N_ "Number to multiply or divide by")
1527 1.0 ;; default
1528 1 ;; lower bound
1529 366.0 ;; upper bound
1530 2.0 ;; number of decimals
1531 1.0 ;; step size
1532 ))
1533;;end of section 3 for gnctimeperiod-utilities
1534;;
1535 ;add select custom date or a specific period
1536 ; changed add-option to gnc:register-trep-option
1537(let ((periodoptions gnc:*transaction-report-options*))
1538
1539
1540 (gnc:register-trep-option
1541 (gnc:make-complex-boolean-option
1542 pagename-compare optname-compare?
1543 "a1" (N_ "Compare multiple periods") #t
1544 #f
1545 (lambda (x)
1546 (gnc-option-db-set-option-selectable-by-name
1547 periodoptions pagename-compare optname-no-base?
1548 x))
1549 ))
1550
1551 (gnc:register-trep-option
1552 (gnc:make-simple-boolean-option
1553 pagename-compare optname-no-base?
1554 "a2" (N_ "If compare periods is unchecked and this box checked only comparison period will be displayed") #f))
1555
1556
1557 (gnc:register-trep-option
1558 (gnc:make-simple-boolean-option
1559 pagename-compare optname-show-average?
1560 "a3" (N_ "Show average for comparison period along with delta from average period") #t))
1561
1562 (gnc:register-trep-option
1563 (gnc:make-multichoice-option pagename-compare (N_ text-compare-divide)
1564 "b" (N_ "Divide period into smaller periods") 'months
1565 gnc:list-comparechoices
1566 ))
1567
1568 (gnc:register-trep-option
1569 (gnc:make-multichoice-callback-option
1570 ; (gnc:make-multichoice-option
1571 pagename-compare (N_ text-whichcompareperiod)
1572 "ca" (N_ "Select which time period to use")
1573 'average
1574;; gnc:list-datechoices-avg
1575;; ))
1576 gnc:list-datechoices-avg #f
1577 (lambda (x)
1578 (gnc-option-db-set-option-selectable-by-name
1579 periodoptions pagename-compare (N_ text-pick-year)
1580 (if (equal? x 'customdates) #f #t))
1581 (gnc-option-db-set-option-selectable-by-name
1582 periodoptions pagename-compare (N_ text-period)
1583 (if (equal? x 'period) #t #f))
1584 (gnc-option-db-set-option-selectable-by-name
1585 periodoptions pagename-compare (N_ text-last)
1586 (if (equal? x 'last) #t #f))
1587 (gnc-option-db-set-option-selectable-by-name
1588 periodoptions pagename-compare (N_ text-month)
1589 (if (equal? x 'month) #t #f))
1590 (gnc-option-db-set-option-selectable-by-name
1591 periodoptions pagename-compare (N_ text-average)
1592 (if (equal? x 'average) #t #f))
1593 (gnc-option-db-set-option-selectable-by-name
1594 periodoptions pagename-compare (N_ text-exclude-average)
1595 (if (equal? x 'average) #t #f))
1596 ))
1597 ))
1598 ; add custom date
1599 (gnc:options-add-date-interval!
1600 gnc:*transaction-report-options* pagename-compare
1601 custom-from-date custom-to-date "cb")
1602
1603 ; add pick year for specific period
1604 (gnc:register-trep-option
1605 (gnc:make-multichoice-option pagename-compare (N_ text-pick-year)
1606 "cc" (N_ "Pick the year for report") 'last-yr
1607 gnc:list-years
1608 ))
1609
1610 ; add pick specific period
1611 (gnc:register-trep-option
1612 (gnc:make-multichoice-option pagename-compare (N_ text-period)
1613 "cf" (N_ "Pick portion of the year for report") 'fullyear
1614 gnc:list-periods
1615 ))
1616 ; add pick specific last XX
1617 (gnc:register-trep-option
1618 (gnc:make-multichoice-option pagename-compare (N_ text-last)
1619 "cg" (N_ "Pick portion of the year for report") 'last_qtr
1620 gnc:list-lasts
1621 ))
1622 ; add pick specific month
1623 (gnc:register-trep-option
1624 (gnc:make-multichoice-option pagename-compare (N_ text-month)
1625 "ch" (N_ "Pick which month for report") '4
1626 gnc:list-months
1627 ))
1628 ; add exclude last week or month from average
1629 (gnc:register-trep-option
1630 (gnc:make-simple-boolean-option
1631 pagename-compare (N_ text-exclude-average)
1632 "ci" (N_ "Do not include the last week in week averages, last month in month averages") #t
1633 ))
1634 ; add pick average period
1635 (gnc:register-trep-option
1636 (gnc:make-multichoice-option pagename-compare (N_ text-average)
1637 "cj" (N_ "Pick portion of the year for report") '3months
1638 gnc:list-average
1639 ))
1640 ; add pick for multiply or divide
1641 (gnc:register-trep-option
1642 (gnc:make-multichoice-option pagename-compare (N_ "Scale Results")
1643 "d1" (N_ "Scale the results - multiply or divide by scale factor") '*
1644 gnc:list-operands
1645 ))
1646 ; add where number for multiply or divide can be changed
1647 (gnc:register-trep-option
1648 (gnc:make-number-range-option pagename-compare (N_ "Scale Number Option")
1649 "d2" (N_ "Number to multiply or divide by")
1650 1.0 ;; default
1651 1 ;; lower bound
1652 366.0 ;; upper bound
1653 2.0 ;; number of decimals
1654 1.0 ;; step size
1655 ))
1656;;end of section 3 for gnctimeperiod-utilities
1657
1658
1659 (gnc:register-trep-option
1660 (gnc:make-simple-boolean-option
1661 pagename-compare optname-scale-automatically?
1662 "e" (N_ "Scale all periods to number of days given below") #f))
1663
1664 (gnc:register-trep-option
1665 (gnc:make-number-range-option pagename-compare optname-scale-to
1666 "f" (N_ "Scale all periods including the base to this number of days")
1667 365.0 ;; default
1668 1 ;; lower bound
1669 366.0 ;; upper bound
1670 0 ;; number of decimals
1671 1.0 ;; step size
1672 ))
1673
1674 ; (gnc:register-trep-option
1675 ; (gnc:make-multichoice-option
1676 ; pagename-general (N_ "Style")
1677 ; "d" (N_ "Report style.")
1678 ; 'single
1679 ; (list (vector 'multi-line
1680 ; (N_ "Multi-Line")
1681 ; (N_ "Display N lines."))
1682 ; (vector 'single
1683 ; (N_ "Single")
1684 ; (N_ "Display 1 line.")))))
1685
1686 (gnc:register-trep-option
1687 (gnc:make-complex-boolean-option
1688 pagename-general optname-common-currency
1689 "e" (N_ "Convert all transactions into a common currency.") #f
1690 #f
1691 (lambda (x) (gnc-option-db-set-option-selectable-by-name
1692 gnc:*transaction-report-options*
1693 pagename-general
1694 optname-currency
1695 x))
1696 ))
1697
1698 (gnc:options-add-currency!
1699 gnc:*transaction-report-options* pagename-general optname-currency "f")
1700
1701 (gnc:register-trep-option
1702 (gnc:make-simple-boolean-option
1703 pagename-general optname-table-export
1704 "g" (N_ "Formats the table suitable for cut & paste exporting with extra cells.") #f))
1705
1706 ;; Accounts options
1707
1708 ;; account to do report on
1709 (gnc:register-trep-option
1710 (gnc:make-account-list-option
1711 pagename-accounts (N_ "Accounts")
1712 "a" (N_ "Report on these accounts.")
1713 ;; select, by default, no accounts! Selecting all accounts will
1714 ;; always imply an insanely long waiting time upon opening, and it
1715 ;; is almost never useful. So we instead display the normal error
1716 ;; message saying "Click here", and the user knows how to
1717 ;; continue.
1718 (lambda ()
1719 '())
1720 #f #t))
1721
1722 (gnc:register-trep-option
1723 (gnc:make-account-list-option
1724 pagename-accounts (N_ "Filter By...")
1725 "b" (N_ "Filter on these accounts.")
1726 (lambda ()
1727 ;; FIXME : gnc:get-current-accounts disappeared.
1728 (let* ((current-accounts '())
1729 (root (gnc-get-current-root-account))
1730 (num-accounts (gnc-account-n-children root))
1731 (first-account (gnc-account-nth-child root 0)))
1732 (cond ((not (null? current-accounts))
1733 (list (car current-accounts)))
1734 ((> num-accounts 0) (list first-account))
1735 (else '()))))
1736 #f #t))
1737
1738 (gnc:register-trep-option
1739 (gnc:make-multichoice-option
1740 pagename-accounts (N_ "Filter Type")
1741 "c" (N_ "Filter account.")
1742 'none
1743 (list (vector 'none
1744 (N_ "None")
1745 (N_ "Do not do any filtering."))
1746 (vector 'include
1747 (N_ "Include Transactions to/from Filter Accounts")
1748 (N_ "Include transactions to/from filter accounts only."))
1749 (vector 'exclude
1750 (N_ "Exclude Transactions to/from Filter Accounts")
1751 (N_ "Exclude transactions to/from all filter accounts."))
1752 )))
1753
1754 ;;
1755
1756 (gnc:register-trep-option
1757 (gnc:make-multichoice-option
1758 pagename-accounts optname-void-transactions
1759 "d" (N_ "How to handle void transactions.")
1760 'non-void-only
1761 (list (vector
1762 'non-void-only
1763 (N_ "Non-void only")
1764 (N_ "Show only non-voided transactions."))
1765 (vector
1766 'void-only
1767 (N_ "Void only")
1768 (N_ "Show only voided transactions."))
1769 (vector
1770 'both
1771 (N_ "Both")
1772 (N_ "Show both (and include void transactions in totals).")))))
1773
1774 ;; Sorting options
1775
1776 (let ((options gnc:*transaction-report-options*)
1777
1778 (key-choice-list
1779 (if (qof-book-use-split-action-for-num-field (gnc-get-current-book))
1780 (list (vector 'none
1781 (N_ "None")
1782 (N_ "Do not sort."))
1783
1784 (vector 'account-name
1785 (N_ "Account Name")
1786 (N_ "Sort & subtotal by account name."))
1787
1788 (vector 'account-code
1789 (N_ "Account Code")
1790 (N_ "Sort & subtotal by account code."))
1791
1792 (vector 'date
1793 (N_ "Date")
1794 (N_ "Sort by date."))
1795
1796 (vector 'corresponding-acc-name
1797 (N_ "Other Account Name")
1798 (N_ "Sort by account transferred from/to's name."))
1799
1800 (vector 'corresponding-acc-code
1801 (N_ "Other Account Code")
1802 (N_ "Sort by account transferred from/to's code."))
1803
1804 (vector 'amount
1805 (N_ "Amount")
1806 (N_ "Sort by amount."))
1807
1808 (vector 'description
1809 (N_ "Description")
1810 (N_ "Sort by description."))
1811
1812 (vector 'memo
1813 (N_ "Memo")
1814 (N_ "Sort by memo.")))
1815 (list (vector 'none
1816 (N_ "None")
1817 (N_ "Do not sort."))
1818
1819 (vector 'account-name
1820 (N_ "Account Name")
1821 (N_ "Sort & subtotal by account name."))
1822
1823 (vector 'account-code
1824 (N_ "Account Code")
1825 (N_ "Sort & subtotal by account code."))
1826
1827 (vector 'date
1828 (N_ "Date")
1829 (N_ "Sort by date."))
1830
1831 (vector 'corresponding-acc-name
1832 (N_ "Other Account Name")
1833 (N_ "Sort by account transferred from/to's name."))
1834
1835 (vector 'corresponding-acc-code
1836 (N_ "Other Account Code")
1837 (N_ "Sort by account transferred from/to's code."))
1838
1839 (vector 'amount
1840 (N_ "Amount")
1841 (N_ "Sort by amount."))
1842
1843 (vector 'description
1844 (N_ "Description")
1845 (N_ "Sort by description."))
1846
1847 (vector 'memo
1848 (N_ "Memo")
1849 (N_ "Sort by memo.")))))
1850
1851 (ascending-choice-list
1852 (list
1853 (vector 'ascend
1854 (N_ "Ascending")
1855 (N_ "Smallest to largest, earliest to latest."))
1856 (vector 'descend
1857 (N_ "Descending")
1858 (N_ "Largest to smallest, latest to earliest."))))
1859
1860 (subtotal-choice-list
1861 (list
1862 (vector 'none (N_ "None") (N_ "None."))
1863 (vector 'weekly (N_ "Weekly") (N_ "Weekly."))
1864 (vector 'monthly (N_ "Monthly") (N_ "Monthly."))
1865 (vector 'quarterly (N_ "Quarterly") (N_ "Quarterly."))
1866 (vector 'yearly (N_ "Yearly") (N_ "Yearly.")))))
1867
1868 ;; primary sorting criterion
1869 (gnc:register-trep-option
1870 (gnc:make-multichoice-callback-option
1871 pagename-sorting optname-prime-sortkey
1872 "a" (N_ "Sort by this criterion first.")
1873 'account-name
1874 key-choice-list #f
1875 (lambda (x)
1876 (gnc-option-db-set-option-selectable-by-name
1877 options pagename-sorting optname-prime-subtotal
1878 (and (member x subtotal-enabled) #t))
1879 (gnc-option-db-set-option-selectable-by-name
1880 options pagename-sorting optname-prime-date-subtotal
1881 (if (member x date-sorting-types) #t #f)))))
1882
1883 (gnc:register-trep-option
1884 (gnc:make-simple-boolean-option
1885 pagename-sorting (N_ "Show Full Account Name")
1886 "a1"
1887 (N_ "Show the full account name for subtotals and subtitles?")
1888 #f))
1889
1890 (gnc:register-trep-option
1891 (gnc:make-simple-boolean-option
1892 pagename-sorting (N_ "Show Account Code")
1893 "a2"
1894 (N_ "Show the account code for subtotals and subtitles?")
1895 #f))
1896
1897 (gnc:register-trep-option
1898 (gnc:make-simple-boolean-option
1899 pagename-sorting optname-prime-subtotal
1900 "c"
1901 (N_ "Subtotal according to the primary key?")
1902 #f))
1903
1904 (gnc:register-trep-option
1905 (gnc:make-multichoice-option
1906 pagename-sorting optname-prime-date-subtotal
1907 "d" (N_ "Do a date subtotal.")
1908 'monthly
1909 subtotal-choice-list))
1910
1911 (gnc:register-trep-option
1912 (gnc:make-multichoice-option
1913 pagename-sorting (N_ "Primary Sort Order")
1914 "e" (N_ "Order of primary sorting.")
1915 'ascend
1916 ascending-choice-list))
1917
1918 ;; Secondary sorting criterion
1919 (gnc:register-trep-option
1920 (gnc:make-multichoice-callback-option
1921 pagename-sorting optname-sec-sortkey
1922 "f"
1923 (N_ "Sort by this criterion second.")
1924 'none
1925 key-choice-list #f
1926 (lambda (x)
1927 (gnc-option-db-set-option-selectable-by-name
1928 options pagename-sorting optname-sec-subtotal
1929 (and (member x subtotal-enabled) #t))
1930 (gnc-option-db-set-option-selectable-by-name
1931 options pagename-sorting optname-sec-date-subtotal
1932 (if (member x date-sorting-types) #t #f)))))
1933
1934 (gnc:register-trep-option
1935 (gnc:make-simple-boolean-option
1936 pagename-sorting optname-sec-subtotal
1937 "g"
1938 (N_ "Subtotal according to the secondary key?")
1939 #t))
1940
1941 (gnc:register-trep-option
1942 (gnc:make-multichoice-option
1943 pagename-sorting optname-sec-date-subtotal
1944 "h" (N_ "Do a date subtotal.")
1945 'yearly
1946 subtotal-choice-list))
1947
1948 (gnc:register-trep-option
1949 (gnc:make-multichoice-option
1950 pagename-sorting (N_ "Secondary Sort Order")
1951 "i" (N_ "Order of Secondary sorting.")
1952 'ascend
1953 ascending-choice-list))
1954
1955
1956;;for find
1957 (gnc:register-trep-option
1958 (gnc:make-simple-boolean-option
1959 pagename-sorting (N_ optname-find-min)
1960 "j1"
1961 (N_ "Only show amounts greater than or equal to")
1962 #f))
1963
1964 (gnc:register-trep-option
1965 (gnc:make-number-range-option pagename-sorting (N_ "Min Amount")
1966 "j2" (N_ "Minimum amount to show")
1967 100.0 ;; default
1968 -900000.0 ;; lower bound
1969 4000000.0 ;; upper bound
1970 2.0 ;; number of decimals
1971 100.0 ;; step size
1972 ))
1973
1974
1975 (gnc:register-trep-option
1976 (gnc:make-simple-boolean-option
1977 pagename-sorting (N_ optname-find-max)
1978 "j3"
1979 (N_ "Only show entries less than or equal")
1980 #f))
1981
1982 (gnc:register-trep-option
1983 (gnc:make-number-range-option pagename-sorting (N_ "Max Amount")
1984 "j4" (N_ "Maximum amount to show")
1985 20000.0 ;; default
1986 -800000.0 ;; lower bound
1987 5000000.0 ;; upper bound
1988 2.0 ;; number of decimals
1989 100.0 ;; step size
1990 ))
1991
1992 ;;
1993 (gnc:register-trep-option
1994 (gnc:make-complex-boolean-option
1995 pagename-sorting (N_ optname-find-text?)
1996 "k1" (N_ "Only show transactions containing the string") #f
1997 #f
1998 (lambda (x) (gnc-option-db-set-option-selectable-by-name
1999 gnc:*transaction-report-options*
2000 pagename-sorting optname-find1-field x)
2001 (gnc-option-db-set-option-selectable-by-name
2002 gnc:*transaction-report-options*
2003 pagename-sorting optname-find1-text
2004 x))
2005 ))
2006
2007 (gnc:register-trep-option
2008 (gnc:make-multichoice-option
2009 pagename-sorting optname-find1-field
2010 "k2" (N_ "Select which field or category to use")
2011 'description
2012 list-findchoices))
2013
2014 (gnc:register-trep-option
2015 (gnc:make-string-option
2016 pagename-sorting optname-find1-text
2017 "k3" (N_ "text to look for (all transactions have a space added at front so ' a' will include all which start with a ") (N_ "")))
2018
2019
2020;
2021; (let ((periodoptions gnc:*transaction-report-options*))
2022 (gnc:register-trep-option
2023; (gnc:make-multichoice-callback-option
2024 (gnc:make-multichoice-option
2025 pagename-sorting optname-find2-operand
2026 "k4" (N_ "Select which field or category to use")
2027 'none
2028 list-find2-operands))
2029; list-findchoices #f
2030; (lambda (x)
2031; (gnc-option-db-set-option-selectable-by-name
2032; gnc:*transaction-report-options*
2033 ; pagename-sorting (N_ text-pick-year)
2034 ; (if (equal? x 'customdates) #f #t))
2035; (gnc-option-db-set-option-selectable-by-name
2036 ; gnc:*transaction-report-options*
2037; pagename-sorting (N_ text-period)
2038 ; (if (equal? x 'period) #t #f))
2039; (gnc-option-db-set-option-selectable-by-name
2040; periodoptions the_tab (N_ text-last)
2041; (if (equal? x 'last) #t #f))
2042; (gnc-option-db-set-option-selectable-by-name
2043 ; periodoptions the_tab (N_ text-month)
2044 ; (if (equal? x 'month) #t #f))
2045; ))
2046; ))
2047;
2048;
2049
2050
2051 (gnc:register-trep-option
2052 (gnc:make-multichoice-option
2053 pagename-sorting optname-find2-field
2054 "k5" (N_ "Select which field or category to use")
2055 'description
2056 list-findchoices))
2057
2058 (gnc:register-trep-option
2059 (gnc:make-string-option
2060 pagename-sorting optname-find2-text
2061 "k6" (N_ "text to look for ") (N_ "")))
2062
2063;end of section for find
2064
2065 )
2066
2067
2068 ;; Display options
2069
2070 (for-each
2071 (lambda (l)
2072 (gnc:register-trep-option
2073 (gnc:make-simple-boolean-option
2074 pagename-display (car l) (cadr l) (caddr l) (cadddr l))))
2075 ;; One list per option here with: option-name, sort-tag,
2076 ;; help-string, default-value
2077 (list
2078 (list optname-consolidate-case-sensitive "a1" (N_ "when not checked \"A\" and \"a\" are considered to be the same letter in comparing descriptions") #f)
2079 (list (N_ "Description") "c" (N_ "Display the description?") #f)
2080 (list optname-descript-titlecase "s" (N_ "Titlecase The First Letter in Each Word") #t)
2081 ;; note the "memo" option in between here
2082 (list (N_ "Notes") "d2" (N_ "Display the notes if the memo is unavailable?") #t)
2083 (list (N_ "Account Name") "e" (N_ "Display the account name?") #t)
2084 (list (N_ "Use Full Account Name") "f" (N_ "Display the full account name?") #t)
2085 (list (N_ "Account Code") "g" (N_ "Display the account code?") #f)
2086 (list (N_ "Other Account Name") "h" (N_ "Display the other account name?\
2087 (if this is a split transaction, this parameter is guessed).") #f)
2088 (list (N_ "Use Full Other Account Name") "i" (N_ "Display the full other account name?") #t)
2089 (list (N_ "Other Account Code") "j" (N_ "Display the other account code?") #f)
2090 ; (list (N_ "Shares") "k" (N_ "Display the number of shares?") #f)
2091 ; (list (N_ "Price") "l" (N_ "Display the shares price?") #f)
2092 ; (list (N_ "Running Balance") "n" (N_ "Display a running balance?") #f)
2093 (list (N_ "Totals") "o" (N_ "Display the totals?") #t)
2094 ;; note the "sign reverse" multichoice option in between here
2095 ; (list (N_ "Use old running balance") "q0" (N_ "Use old method of computing running balance , may need for different currencies") #f)
2096 (list optname-days "q1" (N_ "Display number of days in each period") #t)
2097 (list optname-show-imbalance "r" opthelp-show-imbalance #t)
2098 ; optname-descript-titlecase is being shown here instead of line d1
2099 ))
2100
2101 (if (qof-book-use-split-action-for-num-field (gnc-get-current-book))
2102 (gnc:register-trep-option
2103 (gnc:make-simple-boolean-option
2104 pagename-display (N_ "Trans Number")
2105 "b2" (N_ "Display the trans number?") #f)))
2106
2107 ;; Add an option to display the memo, and disable the notes option
2108 ;; when memos are not included.
2109 (gnc:register-trep-option
2110 (gnc:make-complex-boolean-option
2111 pagename-display (N_ "Memo")
2112 "d" (N_ "Display the memo?") #f
2113 #f
2114 (lambda (x) (gnc-option-db-set-option-selectable-by-name
2115 gnc:*transaction-report-options*
2116 pagename-display
2117 (N_ "Notes")
2118 x))))
2119
2120 (gnc:register-trep-option
2121 (gnc:make-multichoice-option
2122 pagename-display (N_ "Sign Reverses")
2123 "p" (N_ "Reverse amount display for certain account types.")
2124 'none
2125 (list
2126 (vector 'none (N_ "None") (N_ "Don't change any displayed amounts."))
2127 (vector 'income-expense (N_ "Income and Expense")
2128 (N_ "Reverse amount display for Income and Expense Accounts."))
2129 (vector 'credit-accounts (N_ "Credit Accounts")
2130 (N_ "Reverse amount display for Liability, Payable, Equity, \
2131Credit Card, and Income accounts.")))))
2132
2133
2134 (gnc:options-set-default-section gnc:*transaction-report-options*
2135 pagename-compare)
2136
2137 gnc:*transaction-report-options*)
2138
2139
2140(define (display-date-interval-find begin end findtitle)
2141 (let ((begin-string (gnc-print-date begin))
2142 (end-string (gnc-print-date end)))
2143 (sprintf #f (_ "From %s To %s%s") begin-string end-string findtitle)))
2144
2145(define (display-find findtitle)
2146 (sprintf #f (_ "%s") findtitle ))
2147
2148(define (display-date-interval-columns begin end)
2149 (let ((begin-string (gnc-print-date begin))
2150 (end-string (gnc-print-date end)))
2151 (sprintf #f (_ "From %s To %s") begin-string end-string )))
2152
2153(define (display-num-days days)
2154 (if (number? days)
2155 (_ (number->string days))
2156 (_ " ")))
2157
2158(define (get-primary-subtotal-style options)
2159 (let ((bgcolor (gnc:lookup-option options
2160 (N_ "Colors")
2161 (N_ "Primary Subtotals/headings"))))
2162 (list 'attribute (list "bgcolor" (gnc:color-option->html bgcolor)))))
2163
2164(define (get-secondary-subtotal-style options)
2165 (let ((bgcolor (gnc:lookup-option options
2166 (N_ "Colors")
2167 (N_ "Secondary Subtotals/headings"))))
2168 (list 'attribute (list "bgcolor" (gnc:color-option->html bgcolor)))))
2169
2170(define (get-grand-total-style options)
2171 (let ((bgcolor (gnc:lookup-option options
2172 (N_ "Colors")
2173 (N_ "Grand Total"))))
2174 (list 'attribute (list "bgcolor" (gnc:color-option->html bgcolor)))))
2175
2176(define (get-odd-row-style options)
2177 (let ((bgcolor (gnc:lookup-option options
2178 (N_ "Colors")
2179 (N_ "Split Odd"))))
2180 (list 'attribute (list "bgcolor" (gnc:color-option->html bgcolor)))))
2181
2182(define (get-even-row-style options)
2183 (let ((bgcolor (gnc:lookup-option options
2184 (N_ "Colors")
2185 (N_ "Split Even"))))
2186 (list 'attribute (list "bgcolor" (gnc:color-option->html bgcolor)))))
2187
2188
2189;; check if the transaction meets the find requirements
2190;;
2191
2192(define (filtersplits-found splits account-types-to-reverse)
2193
2194 (define (splitfound? currentsplit )
2195 ; (if (not (null? splits))
2196
2197 (let* (
2198 (parent (xaccSplitGetParent currentsplit))
2199 (descript (xaccTransGetDescription parent))
2200
2201 (account (xaccSplitGetAccount currentsplit))
2202 (account-type (xaccAccountGetType account))
2203 (damount (if (gnc:split-voided? currentsplit)
2204 (xaccSplitVoidFormerAmount currentsplit)
2205 (xaccSplitGetAmount currentsplit)))
2206 (currency (if (not (null? account))
2207 (xaccAccountGetCommodity account)
2208 (gnc-default-currency)))
2209 (report-currency (if comm-curr?
2210 curr
2211 currency))
2212 (trans-date (gnc-transaction-get-date-posted parent))
2213
2214 (split-value (gnc:exchange-by-pricedb-nearest
2215 (gnc:make-gnc-monetary
2216 currency
2217 (if (member account-type account-types-to-reverse)
2218 (gnc-numeric-neg damount)
2219 damount))
2220 report-currency
2221 ;; Use midday as the transaction time so it matches a price
2222 ;; on the same day. Otherwise it uses midnight which will
2223 ;; likely match a price on the previous day
2224 (timespecCanonicalDayTime trans-date)))
2225 )
2226;;;;;
2227 (define (found-text? which-field text-to-find ); based on entries in find-field-number
2228 (case which-field
2229 ((10) ; 'description
2230 (string-contains (string-append " " (string-upcase (xaccTransGetDescription parent) ) " ") text-to-find))
2231 ((13) ; 'memo
2232 (string-contains (string-append " " (string-upcase (xaccSplitGetMemo currentsplit) ) " ") text-to-find))
2233 ((14) ; 'notes
2234 (string-contains (string-append " " (string-upcase (xaccTransGetNotes parent) ) " ") text-to-find))
2235 (( 1) ; 'account-name
2236 (string-contains (string-append " " (string-upcase (gnc-account-get-full-name account) ) " ") text-to-find))
2237 (( 2) ;'accountcodee
2238 (string-contains (string-append " " (string-upcase (xaccAccountGetCode account) ) " ") text-to-find))
2239 ((16 ) ; 'memo/notes
2240 (or (string-contains (string-append " " (string-upcase (xaccSplitGetMemo currentsplit) ) " ") text-to-find) ;memo
2241 (string-contains (string-append " " (string-upcase (xaccTransGetNotes parent) ) " ") text-to-find))) ;notes
2242 ((15) ; 'any
2243 (or (string-contains (string-append " " (string-upcase (xaccTransGetDescription parent) ) " ") text-to-find) ;description
2244 (string-contains (string-append " " (string-upcase (xaccSplitGetMemo currentsplit) ) " ") text-to-find) ; memo
2245 (string-contains (string-append " " (string-upcase (xaccTransGetNotes parent) ) " ") text-to-find) ;notes
2246 (string-contains (string-append " " (string-upcase (gnc-account-get-full-name account) ) " ") text-to-find) ;account-name
2247 (string-contains (string-append " " (string-upcase (xaccAccountGetCode account) ) " ") text-to-find))) ; account-code
2248 ((11) ; 'number
2249 (or (string-contains (string-append " " (string-upcase (gnc-get-num-action parent currentsplit) ) " ") text-to-find) ;num
2250 (if (gnc-get-num-action parent #f)
2251 (string-contains (string-append " " (string-upcase (gnc-get-num-action parent #f) ) " ") text-to-find); Trans Number
2252 #f)))
2253 (( 3) ; 'date
2254 (string-contains (string-append " " (string-upcase (gnc-print-date (gnc-transaction-get-date-posted parent) )) " ") text-to-find)) ;date
2255 (( 5) ; 'reconciled-date
2256 (let* ((date (gnc-split-get-date-reconciled currentsplit))
2257 (printed-date (if (equal? date (cons 0 0))
2258 ""
2259 (gnc-print-date date))))
2260 (string-contains (string-append " " (string-upcase printed-date) " ") text-to-find))) ;reconciled date
2261 ((17) ; 'reconcile
2262 (string-contains (string-append " " (string-upcase (string (xaccSplitGetReconcile currentsplit)) ) " ") text-to-find))
2263
2264 ))
2265;;;;;;
2266
2267 (or (not find-text?)
2268 (if find-text?
2269 (let* ((found1? (found-text? find1-field find1-text)))
2270 (if (equal? find2-operand 'none)
2271 found1?
2272 (if (equal? find2-operand 'and)
2273 (and found1? (found-text? find2-field find2-text))
2274 (if (equal? find2-operand 'or)
2275 (or found1? (found-text? find2-field find2-text))
2276 (if (equal? find2-operand 'not)
2277 (and found1? (not (found-text? find2-field find2-text)))
2278 #f)))))
2279 #f)
2280 )
2281 )
2282 )
2283 (filter splitfound? splits )
2284 )
2285
2286 ;
2287
2288(define (find-monetary? value-monetary) ; only handles ammount - the find for text was handled earlier
2289 (let ((value-num (gnc:gnc-numeric-num (gnc:gnc-monetary-amount value-monetary))))
2290 (and
2291 (or (not find-min?) (>= value-num find-min ))
2292 (or (not find-max?) (<= value-num find-max ))
2293 )
2294))
2295
2296;;
2297; swap hash table keys and values so can look up stored currency string and get currency
2298(define (hash-for-eachq x) (lambda (key val)
2299 (hash-set! currency-lookup-hash val key))
2300 currency-type-hash)
2301
2302;; ;;;;;;;;;;;;;;;;;;;;
2303;; for working on consolidating descriptions
2304;; Here comes the big function that builds the whole table.
2305(define (make-split-table-comp list-thekeys options
2306 primary-comp-key secondary-comp-key
2307 comp-primary-subtotal-pred
2308 comp-secondary-subtotal-pred
2309 comp-primary-subheading-renderer
2310 comp-secondary-subheading-renderer
2311 comp-primary-subtotal-renderer
2312 comp-secondary-subtotal-renderer)
2313
2314
2315 (let ((work-to-do (length list-thekeys))
2316 (work-done 0)
2317 (used-columns (build-column-used options)))
2318
2319 (define (transaction-report-multi-rows-p options)
2320 ; (eq? (gnc:option-value
2321 ; (gnc:lookup-option options pagename-general (N_ "Style")))
2322 ; 'multi-line)
2323 #f
2324 )
2325
2326 (define (transaction-report-export-p options)
2327 (gnc:option-value
2328 (gnc:lookup-option options pagename-general
2329 optname-table-export)))
2330
2331 (define (add-other-split-rows split split-trans table used-columns
2332 row-style account-types-to-reverse)
2333 (define (comp-other-rows-driver split split-trans parent table used-columns i)
2334 (let ((current-trans split-trans)
2335 ;(current (xaccTransGetSplit parent i)) ;needs work?
2336 )
2337 (cond ((null? current-trans) #f)
2338 ((equal? current-trans split-trans) ;always true - can remove?
2339 (comp-other-rows-driver split split-trans parent table used-columns (+ i 1)))
2340 (else (begin
2341 (add-split-row-comp table current-trans
2342 used-columns options
2343 row-style account-types-to-reverse #f)
2344 (comp-other-rows-driver split split-trans parent table used-columns
2345 (+ i 1)))))))
2346
2347 (comp-other-rows-driver split split-trans (xaccSplitGetParent split)
2348 table used-columns 0))
2349
2350 (define (add-to-total subtotal-hash split-trans)
2351 ;;
2352 ; now to add to the sum for each column but first need to handle case where multiple currencies
2353 (let (
2354 (the-currency (get-currency-type split-trans))
2355 (currency (hash-ref currency-lookup-hash (get-currency-type split-trans)))
2356 )
2357 ;; add to total for the account column
2358 (let* ( (col 1))
2359 (while (<= col last-column) ;; change column
2360 (hash-set! subtotal-hash (string-append (number->string col) "#Vv;" the-currency)
2361 (gnc:make-gnc-monetary currency
2362 (gnc-numeric-add
2363 (gnc:gnc-monetary-amount
2364 (get-monetary split-trans col))
2365 (gnc:gnc-monetary-amount
2366 (hash-ref subtotal-hash (string-append (number->string col) "#Vv;" the-currency)
2367 (gnc:make-gnc-monetary currency (gnc-numeric-zero))))
2368 GNC-DENOM-AUTO GNC-RND-ROUND))
2369 )
2370 (set! col (+ col 1))
2371 )
2372)
2373))
2374 ;;
2375
2376 (define (do-rows-with-subtotals list-thekeys
2377 table
2378 used-columns
2379 width
2380 multi-rows?
2381 odd-row?
2382 export?
2383 account-types-to-reverse
2384 comp-primary-subtotal-pred
2385 comp-secondary-subtotal-pred
2386 comp-primary-subheading-renderer
2387 comp-secondary-subheading-renderer
2388 comp-primary-subtotal-renderer
2389 comp-secondary-subtotal-renderer
2390 primary-subtotal-collector
2391 secondary-subtotal-collector
2392 total-collector)
2393
2394 (gnc:report-percent-done (* 100 (/ work-done work-to-do)))
2395 (set! work-done (+ 1 work-done))
2396
2397 (if (null? list-thekeys)
2398 (begin
2399 (gnc:html-table-append-row/markup!
2400 table
2401 def:grand-total-style
2402 (list
2403 (gnc:make-html-table-cell/size
2404 1 width (gnc:make-html-text (gnc:html-markup-hr)))))
2405 (if (gnc:option-value (gnc:lookup-option options pagename-display "Totals"))
2406 (comp-render-grand-total table width total-collector total-collector-hash export?)))
2407
2408 (let* (
2409 (current-trans (car list-thekeys))
2410
2411 (current-row-style (if multi-rows? def:normal-row-style
2412 (if odd-row? def:normal-row-style
2413 def:alternate-row-style)))
2414 (rest-trans (cdr list-thekeys))
2415 (next-trans (if (null? rest-trans) #f
2416 (car rest-trans)))
2417 (split-value (add-split-row-comp ;;this currently adds a row of output and then returns amount in base column
2418 table
2419 current-trans
2420 used-columns
2421 options
2422 current-row-style
2423 account-types-to-reverse
2424 #t)))
2425 ; (if multi-rows?
2426 ; (add-other-split-rows
2427 ; current current-trans table used-columns def:alternate-row-style
2428 ; account-types-to-reverse))
2429
2430 (primary-subtotal-collector 'add ;; change primary-subtotal collector 'add to say
2431 ;; (add-to-total primary-subtotal-collector-hash current-trans)
2432 ;; currently adds in amount from base column , change to add each col to that
2433 ;; columns total
2434 (gnc:gnc-monetary-commodity
2435 split-value)
2436 (gnc:gnc-monetary-amount
2437 split-value))
2438 (add-to-total primary-subtotal-collector-hash current-trans)
2439 (secondary-subtotal-collector 'add ;; currently adds in amount from base column , change to add each col to that
2440 (gnc:gnc-monetary-commodity ;; columns total
2441 split-value)
2442 (gnc:gnc-monetary-amount
2443 split-value))
2444 (add-to-total secondary-subtotal-collector-hash current-trans)
2445 (add-to-total total-collector-hash current-trans)
2446
2447 (total-collector 'add
2448 (gnc:gnc-monetary-commodity split-value)
2449 (gnc:gnc-monetary-amount split-value))
2450
2451 (if (and comp-primary-subtotal-pred
2452 (or (not next-trans)
2453 (and next-trans
2454 (not (comp-primary-subtotal-pred (get-primary-key current-trans) (get-primary-key next-trans))))))
2455
2456 (begin
2457 (if comp-secondary-subtotal-pred
2458
2459 (begin
2460 (comp-secondary-subtotal-renderer ;; change to show each columns total for secondary instead of just base
2461 table width current-trans (get-secondary-key current-trans)
2462 secondary-subtotal-collector
2463 secondary-subtotal-collector-hash
2464 def:secondary-subtotal-style used-columns export?)
2465 (set! secondary-subtotal-collector-hash (make-hash-table))
2466 (secondary-subtotal-collector 'reset #f #f)))
2467
2468 (comp-primary-subtotal-renderer table width current-trans (get-primary-key current-trans)
2469 primary-subtotal-collector
2470 primary-subtotal-collector-hash
2471 def:primary-subtotal-style used-columns
2472 export?)
2473 (set! primary-subtotal-collector-hash (make-hash-table))
2474 (primary-subtotal-collector 'reset #f #f)
2475
2476 (if next-trans
2477 (begin
2478 (comp-primary-subheading-renderer
2479 next-trans (get-primary-key next-trans) table width def:primary-subtotal-style used-columns)
2480
2481 (if comp-secondary-subtotal-pred
2482 (comp-secondary-subheading-renderer
2483 next-trans (get-secondary-key next-trans)
2484 table
2485 width def:secondary-subtotal-style used-columns)))))
2486
2487 (if (and comp-secondary-subtotal-pred
2488 (or (not next-trans)
2489 (and next-trans
2490 (not (comp-secondary-subtotal-pred
2491 (get-secondary-key current-trans) (get-secondary-key next-trans))))))
2492 (begin (comp-secondary-subtotal-renderer
2493 table width current-trans (get-secondary-key current-trans)
2494 secondary-subtotal-collector
2495 secondary-subtotal-collector-hash
2496 def:secondary-subtotal-style used-columns export?)
2497 (set! secondary-subtotal-collector-hash (make-hash-table))
2498 (secondary-subtotal-collector 'reset #f #f)
2499 (if next-trans
2500 (comp-secondary-subheading-renderer
2501 next-trans (get-secondary-key next-trans) table width
2502 def:secondary-subtotal-style used-columns)))))
2503
2504 (do-rows-with-subtotals rest-trans
2505 table
2506 used-columns
2507 width
2508 multi-rows?
2509 (not odd-row?)
2510 export?
2511 account-types-to-reverse
2512 comp-primary-subtotal-pred
2513 comp-secondary-subtotal-pred
2514 comp-primary-subheading-renderer
2515 comp-secondary-subheading-renderer
2516 comp-primary-subtotal-renderer
2517 comp-secondary-subtotal-renderer
2518 primary-subtotal-collector
2519 secondary-subtotal-collector
2520 total-collector))))
2521
2522
2523 (let* ((table (gnc:make-html-table))
2524 (width (+ columns-headings 0))
2525 (multi-rows? (transaction-report-multi-rows-p options))
2526 (export? (transaction-report-export-p options))
2527 (account-types-to-reverse
2528 (get-account-types-to-reverse options)))
2529
2530 (gnc:html-table-set-col-headers!
2531 table
2532 (make-heading-list used-columns options))
2533
2534 (if show-days?
2535 (make-heading-days table def:primary-subtotal-style))
2536 (if scaled?
2537 (make-heading-scale table def:primary-subtotal-style))
2538 ;; (gnc:warn "Split-trans:" split-transs)
2539 (if (not (null? list-thekeys))
2540 (begin
2541 (set! amount-total-hash (make-hash-table))
2542 (if comp-primary-subheading-renderer ;;print heading above the items we will print (be they transactions or accounts or ...)
2543 (comp-primary-subheading-renderer
2544 (car list-thekeys) (get-primary-key (car list-thekeys)) table width def:primary-subtotal-style used-columns))
2545 (if comp-secondary-subheading-renderer
2546 (comp-secondary-subheading-renderer
2547 (car list-thekeys) (get-secondary-key (car list-thekeys)) table width def:secondary-subtotal-style used-columns))
2548 (set! primary-subtotal-collector-hash (make-hash-table))
2549 (set! secondary-subtotal-collector-hash (make-hash-table))
2550 (set! total-collector-hash (make-hash-table))
2551 (do-rows-with-subtotals list-thekeys table used-columns width
2552 multi-rows? #t
2553 export?
2554 account-types-to-reverse
2555 comp-primary-subtotal-pred
2556 comp-secondary-subtotal-pred
2557 comp-primary-subheading-renderer
2558 comp-secondary-subheading-renderer
2559 comp-primary-subtotal-renderer
2560 comp-secondary-subtotal-renderer
2561 (gnc:make-commodity-collector)
2562 (gnc:make-commodity-collector)
2563 (gnc:make-commodity-collector))))
2564
2565 table)))
2566
2567
2568
2569;; end of the big function for composite / consolidating
2570
2571;; ;;;;;;;;;;;;;;;;;;;;
2572;; Here comes the renderer function for this report.
2573(define (trep-renderer report-obj)
2574
2575 (define options (gnc:report-options report-obj))
2576
2577 (define (opt-val section name)
2578 (gnc:option-value
2579 (gnc:lookup-option options section name)))
2580
2581 ;;(define (get-other-account-names account-list)
2582 ;; ( map (lambda (acct) (gnc-account-get-full-name acct)) account-list))
2583
2584 (define (is-filter-member split account-list)
2585 (let* ((txn (xaccSplitGetParent split))
2586 (splitcount (xaccTransCountSplits txn)))
2587
2588 (cond
2589 ;; A 2-split transaction - test separately so it can be optimized
2590 ;; to significantly reduce the number of splits to traverse
2591 ;; in guile code
2592 ((= splitcount 2)
2593 (let* ((other (xaccSplitGetOtherSplit split))
2594 (other-acct (xaccSplitGetAccount other)))
2595 (member other-acct account-list)))
2596
2597 ;; A multi-split transaction - run over all splits
2598 ((> splitcount 2)
2599 (let ((splits (xaccTransGetSplitList txn)))
2600
2601 ;; Walk through the list of splits.
2602 ;; if we reach the end, return #f
2603 ;; if the 'this' != 'split' and the split->account is a member
2604 ;; of the account-list, then return #t, else recurse
2605 (define (is-member splits)
2606 (if (null? splits)
2607 #f
2608 (let* ((this (car splits))
2609 (rest (cdr splits))
2610 (acct (xaccSplitGetAccount this)))
2611 (if (and (not (eq? this split))
2612 (member acct account-list))
2613 #t
2614 (is-member rest)))))
2615
2616 (is-member splits)))
2617
2618 ;; Single transaction splits
2619 (else #f))))
2620
2621
2622 ;; for composite
2623 ;;
2624 (define comp-comp-funcs-assoc-list
2625 ;; Defines the different sorting keys, together with the
2626 ;; subtotal functions. Each entry: (cons
2627 ;; 'sorting-key-option-value (vector 'query-sorting-key
2628 ;; subtotal-function subtotal-renderer))
2629;; (let* ((used-columns (build-column-used options))) ;; tpo: gives unbound variable options?
2630 (let* ((used-columns (build-column-used (gnc:report-options report-obj))))
2631 (list (cons 'account-name (vector
2632 (list SPLIT-ACCT-FULLNAME)
2633 comp-split-account-full-name-same-p
2634 comp-render-account-subheading
2635 comp-render-account-subtotal))
2636 (cons 'account-code (vector
2637 (list SPLIT-ACCOUNT ACCOUNT-CODE-)
2638 comp-split-account-code-same-p
2639 comp-render-account-subheading
2640 comp-render-account-subtotal))
2641 (cons 'date (vector
2642 (list SPLIT-TRANS TRANS-DATE-POSTED)
2643 #f #f #f))
2644 (cons 'corresponding-acc-name
2645 (vector
2646 (list SPLIT-CORR-ACCT-NAME)
2647 comp-split-same-corr-account-full-name-p
2648 comp-render-corresponding-account-subheading
2649 comp-render-corresponding-account-subtotal))
2650 (cons 'corresponding-acc-code
2651 (vector
2652 (list SPLIT-CORR-ACCT-CODE)
2653 comp-split-same-corr-account-code-p
2654 comp-render-corresponding-account-subheading
2655 comp-render-corresponding-account-subtotal))
2656 (cons 'amount (vector (list SPLIT-VALUE) #f #f #f))
2657 (cons 'description (vector (list SPLIT-TRANS TRANS-DESCRIPTION) #f #f #f))
2658 (cons 'memo (vector (list SPLIT-MEMO) #f #f #f))
2659 (cons 'none (vector '() #f #f #f)))))
2660
2661 (define comp-date-comp-funcs-assoc-list
2662 ;; Extra list for date option. Each entry: (cons
2663 ;; 'date-subtotal-option-value (vector subtotal-function
2664 ;; subtotal-renderer))
2665 (list
2666 (cons 'none (vector #f #f #f))
2667 (cons 'weekly (vector comp-split-same-week-p comp-render-week-subheading
2668 comp-render-week-subtotal))
2669 (cons 'monthly (vector comp-split-same-month-p comp-render-month-subheading
2670 comp-render-month-subtotal))
2671 (cons 'quarterly (vector comp-split-same-quarter-p comp-render-quarter-subheading
2672 comp-render-quarter-subtotal))
2673 (cons 'yearly (vector comp-split-same-year-p comp-render-year-subheading
2674 comp-render-year-subtotal))))
2675
2676 (define (comp-get-subtotalstuff-helper
2677 name-sortkey name-subtotal name-date-subtotal
2678 comp-index date-index)
2679 ;; The value of the sorting-key multichoice option.
2680 (let ((sortkey (opt-val pagename-sorting name-sortkey)))
2681 (if (member sortkey date-sorting-types)
2682 ;; If sorting by date, look up the value of the
2683 ;; date-subtotalling multichoice option and return the
2684 ;; corresponding funcs in the assoc-list.
2685 (vector-ref
2686 (cdr (assq (opt-val pagename-sorting name-date-subtotal)
2687 comp-date-comp-funcs-assoc-list))
2688 date-index)
2689 ;; For everything else: 1. check whether sortkey has
2690 ;; subtotalling enabled at all, 2. check whether the
2691 ;; enable-subtotal boolean option is #t, 3. look up the
2692 ;; appropriate funcs in the assoc-list.
2693 (and (member sortkey subtotal-enabled)
2694 (and (opt-val pagename-sorting name-subtotal)
2695 (vector-ref
2696 (cdr (assq sortkey comp-comp-funcs-assoc-list))
2697 comp-index))))))
2698
2699 (define (comp-get-query-sortkey sort-option-value)
2700 (vector-ref
2701 (cdr (assq sort-option-value comp-comp-funcs-assoc-list))
2702 0))
2703
2704 (define (comp-get-subtotal-pred
2705 name-sortkey name-subtotal name-date-subtotal)
2706 (comp-get-subtotalstuff-helper
2707 name-sortkey name-subtotal name-date-subtotal
2708 1 0))
2709
2710 (define (comp-get-subheading-renderer
2711 name-sortkey name-subtotal name-date-subtotal)
2712 (comp-get-subtotalstuff-helper
2713 name-sortkey name-subtotal name-date-subtotal
2714 2 1))
2715
2716 (define (comp-get-subtotal-renderer
2717 name-sortkey name-subtotal name-date-subtotal)
2718 (comp-get-subtotalstuff-helper
2719 name-sortkey name-subtotal name-date-subtotal
2720 3 2))
2721
2722
2723 ;;
2724
2725
2726 (define timeperiods
2727 (list
2728 (cons 'weekly 1)
2729 (cons 'monthly 2)
2730 (cons 'quarterly 3)
2731 (cons 'yearly 4)
2732 (cons 'none 5)
2733 ))
2734
2735;;
2736(define sort-key-number
2737 (list
2738 (cons 'none 0)
2739 (cons 'account-name 1)
2740 (cons 'account-code 2)
2741 (cons 'date 3)
2742 (cons 'exact-time 4)
2743 (cons 'reconciled-date 5)
2744 (cons 'register-order 6)
2745 (cons 'corresponding-acc-name 7)
2746 (cons 'corresponding-acc-code 8)
2747 (cons 'amount 9)
2748 (cons 'description 10)
2749 (cons 'memo 13)
2750 )
2751 )
2752
2753
2754(define (get-sort-type primary-key secondary-key)
2755 (if (not (equal? primary-key 'amount))
2756 (if (equal? secondary-key 'amount)
2757 'primary_amount
2758 'primary_secondary)
2759 (if (equal? secondary-key 'amount)
2760 'amount_amount
2761 'amount_secondary)
2762 ))
2763
2764
2765(define comp-sort-list
2766 ;; List for sorting consolidated transactions. Each entry: (cons
2767 ;; 'type-of-comparison (vector get-first-variable compare-first-variable compare-first-if-normal-order
2768 ;; compare-first-variable-if-reverse-sort get-second-variable compare-second-variable
2769 ;; compare-second-standard-oder compare-second-variable-reverse-order ))
2770 (list
2771 ;; comparing how to get variable match ascend descend
2772 (cons 'primary_secondary (vector get-primary-key string-ci=? string-ci<? string-ci>?
2773 get-secondary-key string-ci=? string-ci<? string-ci>? ))
2774
2775 (cons 'primary_amount (vector get-primary-key string-ci=? string-ci<? string-ci>?
2776 get-array-value-num-base = < > ))
2777
2778 (cons 'amount_secondary (vector get-array-value-num-base = < >
2779 get-secondary-key string-ci=? string-ci<? string-ci>?))
2780
2781 (cons 'amount_amount (vector get-array-value-num-base = < >
2782 get-array-value-num-base = < > )))
2783)
2784
2785(define (comp-sort-helper sort-option-value col-index)
2786 (vector-ref
2787 (cdr (assq sort-option-value comp-sort-list))
2788 col-index))
2789
2790
2791;;
2792(define (get-the-transactions splits account-full-name? account-code? consolidate-case-sensitive? primary-comp-key secondary-comp-key)
2793 ;; get-the-transactions takes the query results and stores them in hash tables named payee-hash
2794 ;; and payee-account-guid-hash - consolidates transactions having same description and or account name
2795 ;;
2796(define (set-date-tm trans-date-tm sort-date-type )
2797 (case sort-date-type
2798 ((5) ; 'none
2799 (set-tm:mday trans-date-tm 1 )
2800 )
2801 ((1) ; 'weekly
2802 (let ((day (gnc:day-of-week trans-date-tm)))
2803 (set! trans-date-tm (gnc:decrement-date trans-date-tm day ))
2804 ))
2805 ((2) ; 'monthly
2806 (set-tm:mday trans-date-tm 1))
2807 ((3) ; 'quarterly
2808 (begin
2809 (set-tm:mday trans-date-tm 1 )
2810 (case (quotient (tm:mon trans-date-tm) 3)
2811 ((0) (set-tm:mon trans-date-tm 0) )
2812 ((1) (set-tm:mon trans-date-tm 3 ) )
2813 ((2) (set-tm:mon trans-date-tm 6) )
2814 ((3) (set-tm:mon trans-date-tm 9))
2815 )
2816 ))
2817 ((4) ; 'yearly
2818 (begin
2819 (set-tm:mday trans-date-tm 1)
2820 (set-tm:mon trans-date-tm 0))
2821 )
2822 )
2823 trans-date-tm
2824 )
2825;;
2826
2827
2828 (define (composite-sort key split column-vector)
2829
2830 (case key
2831 ((0) ; 'none
2832 " "
2833 )
2834 ((1) ; 'account-name
2835 (let (
2836 (account (xaccSplitGetAccount split)))
2837 (if account-full-name?
2838 (string-append "#Yv;" (gnc-account-get-full-name account) )
2839 (string-append (gnc-account-get-full-name account) "#Yv;" (xaccAccountGetName account))))
2840 )
2841 ((2) ; 'account-code
2842 (let (
2843 (account (xaccSplitGetAccount split)))
2844 (if account-full-name?
2845 (string-append (xaccAccountGetCode account) " " (gnc-account-get-full-name account) )
2846 (string-append (xaccAccountGetCode account) " " (xaccAccountGetName account)))
2847 )
2848 )
2849 ((3) ; 'date
2850 (let* (
2851 (parent (xaccSplitGetParent split))
2852 (trans-date (gnc-transaction-get-date-posted parent))
2853 (tm (gnc:timepair->date trans-date))
2854 (date-string (if (> 5 sort-date-type)
2855 (strftime "%Y%m%d" (set-date-tm tm sort-date-type))
2856 "")))
2857 date-string)
2858 )
2859 ((4) ; 'exact-time
2860 " "
2861 )
2862 ((5) ; 'reconciled-date
2863 (let* ((date (gnc-split-get-date-reconciled split))
2864 (primary-type (if (equal? primary-comp-key 5)
2865 (cdr (assq (opt-val pagename-sorting optname-prime-date-subtotal) timeperiods ))
2866 5)) ;no date requirement
2867 (sec-type (if (equal? secondary-comp-key 5)
2868 (assq-ref timeperiods (opt-val pagename-sorting optname-sec-date-subtotal) )
2869 5)) ;no date requirement
2870 (sort-date-type (min primary-type sec-type ))
2871 (date-string
2872 (if (equal? date (cons 0 0))
2873 " "
2874 (strftime "%Y%m%d" (set-date-tm (gnc:timepair->date date) sort-date-type))
2875 )))
2876 date-string)
2877 )
2878 ((6) ; 'register-order
2879 " "
2880 )
2881 ((7) ; 'corresponding-acc-name currently not connected
2882 " "
2883 )
2884 ((8) ; 'corresponding-acc-code currently not connected
2885 " "
2886 )
2887 ((9) ; 'amount - handled in another part of program
2888 " "
2889 )
2890 ((10) ; 'description
2891 (let* (
2892 (parent (xaccSplitGetParent split))
2893 (descript (if consolidate-case-sensitive?
2894 (xaccTransGetDescription parent)
2895 (string-capitalize (xaccTransGetDescription parent))))
2896 )
2897 (if (< 0 (string-length descript))
2898 descript
2899 " ")
2900 )
2901 )
2902 ((11) ; 'number
2903 " "
2904 )
2905 ((12) ; 't-number
2906 " "
2907 )
2908 ((13) ; 'memo
2909 (let* (
2910 (parent (xaccSplitGetParent split))
2911 (memo (xaccSplitGetMemo split))
2912 (notes (xaccTransGetNotes parent))
2913 (note-memo (if (< 0 (string-length memo))
2914 memo
2915 (if (and (< 0 (string-length notes)) (used-notes column-vector))
2916 notes
2917 " ")))
2918 )
2919 (if consolidate-case-sensitive?
2920 note-memo
2921 (string-upcase note-memo))
2922 ))
2923 ))
2924
2925
2926
2927 (let*
2928 ((split (car splits))
2929 (rest (cdr splits))
2930 (parent (xaccSplitGetParent split))
2931 (account (xaccSplitGetAccount split))
2932; (account-other (xaccSplitGetOtherSplit split))
2933 (account-guid (gncAccountGetGUID account))
2934 (trans-guid (gncTransGetGUID parent ))
2935 (acctfull (gnc-account-get-full-name account))
2936 (acctgetnam (xaccAccountGetName account))
2937
2938; (acct-comm (xaccAccountGetCommodity account))
2939; (shares (xaccSplitGetAmount split))
2940; (comodmul (gnc-commodity-numeric->string acct-comm shares))
2941; (transcurr (xaccTransGetCurrency parent))
2942; (shareprice (xaccSplitGetSharePrice split))
2943
2944 (column-vector (build-column-used options))
2945 (descript-raw (if (used-description column-vector)
2946 (xaccTransGetDescription parent)
2947 " "))
2948 (guids+description (list
2949 trans-guid
2950 account-guid
2951 descript-raw)
2952 )
2953
2954 (descript (if consolidate-case-sensitive?
2955 descript-raw
2956 (string-upcase descript-raw)
2957 ))
2958
2959 (currency (if (not (null? account))
2960 (xaccAccountGetCommodity account)
2961 (gnc-default-currency)))
2962 (damount (if (gnc:split-voided? split)
2963 (xaccSplitVoidFormerAmount split)
2964 (xaccSplitGetAmount split)))
2965 (report-currency (if (opt-val pagename-general optname-common-currency)
2966 (opt-val pagename-general optname-currency)
2967 currency))
2968 (account-type (xaccAccountGetType account))
2969 (account-types-to-reverse (get-account-types-to-reverse options))
2970 (trans-date (gnc-transaction-get-date-posted parent))
2971 (member-reverse-sign (if (member account-type account-types-to-reverse)
2972 "r"
2973 ""))
2974 (split-value (gnc:exchange-by-pricedb-nearest
2975 (gnc:make-gnc-monetary
2976 currency
2977 (if (equal? member-reverse-sign "r")
2978 (gnc-numeric-neg damount)
2979 damount))
2980 report-currency
2981 ;; Use midday as the transaction time so it matches a price
2982 ;; on the same day. Otherwise it uses midnight which will
2983 ;; likely match a price on the previous day
2984 (timespecCanonicalDayTime trans-date)))
2985 (split-value-mon (gnc:gnc-monetary-amount split-value))
2986
2987 ; to print weekly, quarterly ...
2988 (tm (gnc:timepair->date (gnc-transaction-get-date-posted parent)))
2989 (date-string (if (> 5 sort-date-type)
2990 (strftime "%Y%m%d" (set-date-tm tm sort-date-type))
2991 ""))
2992
2993 ; use composite sort to read into primary and secondary sort the item, such as description
2994 ; can not convert everything to upper case here because the marker #Yv; is used in account code
2995 (primary-sort (composite-sort primary-comp-key split column-vector))
2996 (secondary-sort (composite-sort secondary-comp-key split column-vector))
2997
2998 ;
2999 ;
3000
3001 ; (notes (xaccTransGetNotes parent))
3002 ; (num (gnc-get-num-action parent split))
3003
3004
3005 (acct-code (if account-code?
3006 (string-append (xaccAccountGetCode account) " ")
3007 ""))
3008
3009 (memo (if (used-memo column-vector)
3010 (let ((memo (xaccSplitGetMemo split)))
3011 (if (and (equal? memo "") (used-notes column-vector))
3012 (xaccTransGetNotes parent)
3013 memo))
3014 ""))
3015 (memo (if consolidate-case-sensitive?
3016 memo
3017 (string-upcase memo)))
3018
3019 (acctnamecode (if (or (used-account-name column-vector) (used-account-code column-vector))
3020 (account-namestring account
3021 (used-account-code column-vector)
3022 (used-account-name column-vector)
3023 (used-account-full-name column-vector))
3024 ""))
3025 (acctothernamcod (if (or (used-other-account-name column-vector) (used-other-account-code column-vector))
3026 (account-namestring (xaccSplitGetAccount
3027 (xaccSplitGetOtherSplit split))
3028 (used-other-account-code column-vector)
3029 (used-other-account-name column-vector)
3030 (used-other-account-full-name column-vector))
3031 "")
3032 )
3033 (hashed-currency (hash-ref currency-type-hash report-currency currency-type-str)) ; in case transactions with same description have different currencies
3034
3035 (hashkey (string-append primary-sort "#Yw;" secondary-sort "#Yx;" date-string "#Yy;"
3036 descript "#Yz;"
3037 acctnamecode "#Zy;" acct-code "#Zx;" acctothernamcod "#Zw;" memo "#Zv;" member-reverse-sign "#Zu;" hashed-currency ))
3038 )
3039 (total-payee-hash-add! payee-hash hashkey split-value-mon payee-account-guid-hash guids+description)
3040 (if (equal? currency-type-str hashed-currency); if we used the current number - add to hash and prepare new number
3041 (begin
3042 (hash-set! currency-type-hash report-currency hashed-currency )
3043 (set! currency-type-num (+ 1 currency-type-num))
3044 (set! currency-type-str (number->string currency-type-num))
3045 ))
3046 (if (> (length rest) 0)
3047 (get-the-transactions rest account-full-name? account-code? consolidate-case-sensitive? primary-comp-key secondary-comp-key ))
3048 )
3049 )
3050;;end of section for consolidate
3051 (define find-field-number
3052 (list
3053 (cons 'none 0)
3054 (cons 'account-name 1)
3055 (cons 'account-code 2)
3056 (cons 'date 3)
3057 (cons 'corresponding-acc-name 7)
3058 (cons 'corresponding-acc-code 8)
3059 (cons 'amount 9)
3060 (cons 'description 10)
3061 (cons 'memo 13)
3062 (cons 'notes 14)
3063 (cons 'any 15)
3064 (cons 'memo/notes 16)
3065 (cons 'reconcile 17)
3066 )
3067 )
3068
3069 (let* ((document (gnc:make-html-document))
3070 (c_account_1 (opt-val pagename-accounts "Accounts"))
3071 (c_account_2 (opt-val pagename-accounts "Filter By..."))
3072 (filter-mode (opt-val pagename-accounts "Filter Type"))
3073 (report-title (opt-val
3074 pagename-general
3075 gnc:optname-reportname)))
3076
3077
3078(define (store-period-values column list_of_trans scaling-mul-val scaling-div-val)
3079;; transfers results for a single period from hash table into a column in the amounts-array along with
3080;; storing the guid in the same array location in the guid-array. Entries are put on the same row as
3081;; the description or account name from earlier periods by using the hash table pointer-hash
3082;; new names are added to the hash table and added at the bottom of the array
3083
3084(if (not (null? splits))
3085(for-each
3086 (lambda (split-trans)
3087 (let* (
3088 (thekey (car split-trans))
3089 (guids+description (hash-ref payee-account-guid-hash thekey ))
3090
3091 (report-currency (hash-ref currency-lookup-hash (get-currency-type split-trans)))
3092 (currency-frac (gnc-commodity-get-fraction report-currency))
3093 (value
3094 (if (= 1 scaling-mul-val)
3095 (get-split-value-numer split-trans)
3096 (gnc-numeric-mul
3097 (gnc:make-gnc-numeric (inexact->exact (* 100 scaling-mul-val)) 100)
3098 (get-split-value-numer split-trans) currency-frac GNC-RND-ROUND)))
3099 (split-value (gnc:make-gnc-monetary report-currency
3100 (if (= 1 scaling-div-val)
3101 value
3102 (gnc-numeric-div value
3103 (gnc:make-gnc-numeric (inexact->exact (* 100 scaling-div-val)) 100)
3104 currency-frac GNC-RND-ROUND))))
3105 (split-value-coll (if (get-reverse-sign? split-trans)
3106 (gnc:make-gnc-monetary report-currency (gnc-numeric-neg (gnc:gnc-monetary-amount split-value)))
3107 split-value))
3108 (row (hash-ref pointer-hash thekey row-number))
3109 )
3110 (array-set! amounts-array split-value row column)
3111 (array-set! guid-array guids+description row column)
3112 (if (eq? row row-number) ; if we wrote it on row-number than we wrote on a new row,
3113 (begin ; set counter "row-number" to point to next unused line and store info about thekey
3114 (hash-set! pointer-hash thekey row-number ) ;store key and the row number where this keys data is stored
3115 ; store this lines key which contains description and or account name etcetra
3116 (array-set! amounts-array report-currency row-number 0 )
3117 ;store guid for account name along with how user stored name
3118 (array-set! guid-array guids+description row-number 0 )
3119 (set! row-number (+ 1 row-number))
3120 ))
3121 ))
3122 list_of_trans
3123))
3124)
3125
3126
3127(define (get-periods-results begin-date end-date)
3128;; based on transaction.scm this routine is basically the transaction.scm program
3129;; converted to a define statement. It
3130;; queries gnucash then stores the results in hash table by calling get-the-transactions
3131;; the store-period-values routine will then transfer this periods results to a columnn an array
3132 (let* (
3133 (primary-key (opt-val pagename-sorting optname-prime-sortkey))
3134 (primary-order (opt-val pagename-sorting "Primary Sort Order"))
3135 (secondary-key (opt-val pagename-sorting optname-sec-sortkey))
3136 (secondary-order (opt-val pagename-sorting "Secondary Sort Order"))
3137
3138;for consolidate
3139 (primary-comp-key (cdr (assq primary-key sort-key-number )))
3140 (secondary-comp-key (cdr (assq secondary-key sort-key-number )))
3141 (consolidate-case-sensitive? (opt-val pagename-display optname-consolidate-case-sensitive))
3142
3143 (void-status (opt-val pagename-accounts optname-void-transactions))
3144
3145 (query (qof-query-create-for-splits)))
3146
3147 ;;(gnc:warn "accts in trep-renderer:" c_account_1)
3148 ;;(gnc:warn "Report Account names:" (get-other-account-names c_account_1))
3149
3150 (if (not (or (null? c_account_1) (and-map not c_account_1)))
3151 (begin
3152 (qof-query-set-book query (gnc-get-current-book))
3153 ;;(gnc:warn "query is:" query)
3154 (xaccQueryAddAccountMatch query
3155 c_account_1
3156 QOF-GUID-MATCH-ANY QOF-QUERY-AND)
3157 (xaccQueryAddDateMatchTS
3158 query #t begin-date #t end-date QOF-QUERY-AND)
3159 (qof-query-set-sort-order query
3160 (comp-get-query-sortkey primary-key)
3161 (comp-get-query-sortkey secondary-key)
3162 '())
3163
3164 (qof-query-set-sort-increasing query
3165 (eq? primary-order 'ascend)
3166 (eq? secondary-order 'ascend)
3167 #t)
3168
3169 (case void-status
3170 ((non-void-only)
3171 (gnc:query-set-match-non-voids-only! query (gnc-get-current-book)))
3172 ((void-only)
3173 (gnc:query-set-match-voids-only! query (gnc-get-current-book)))
3174 (else #f))
3175 ; (set! splits '()) ;may be able to delete
3176 (set! splits (qof-query-run query))
3177
3178 ;;(gnc:warn "Splits in trep-renderer:" splits)
3179
3180 ;;(gnc:warn "Filter account names:" (get-other-account-names c_account_2))
3181
3182 ;;This should probably a cond or a case to allow for different filter types.
3183 ;;(gnc:warn "Filter Mode: " filter-mode)
3184 (if (eq? filter-mode 'include)
3185 (begin
3186 ;;(gnc:warn "Including Filter Accounts")
3187 (set! splits (filter (lambda (split)
3188 (is-filter-member split c_account_2))
3189 splits))
3190 )
3191 )
3192
3193 (if (eq? filter-mode 'exclude)
3194 (begin
3195 ;;(gnc:warn "Excluding Filter Accounts")
3196 (set! splits (filter (lambda (split)
3197 (not (is-filter-member split c_account_2)))
3198 splits))
3199 )
3200 )
3201
3202
3203;; for find text
3204(if (and (not (null? splits)) find-text?)
3205 (let(
3206 (account-types-to-reverse (get-account-types-to-reverse options)))
3207 (set! splits (filtersplits-found splits account-types-to-reverse))))
3208 ))
3209
3210 (qof-query-destroy query)
3211
3212;; for composite transaction corr
3213
3214 (if (not (null? splits))
3215 (begin
3216
3217 (hash-clear! payee-hash )
3218 (hash-clear! payee-account-guid-hash)
3219
3220 (get-the-transactions splits ;; routine to consolidate the transactions
3221 (opt-val pagename-sorting (N_ "Show Full Account Name")) ;for sort subheadings , not for display on each trans
3222 (opt-val pagename-sorting (N_ "Show Account Code")) ; not the display tab flag, used for sort headings
3223 consolidate-case-sensitive?
3224 primary-comp-key secondary-comp-key
3225 )
3226
3227 (set! list_of_trans (hash-map->list cons payee-hash)) ;list of all of the transactions in the period
3228
3229
3230 ; swap hash table keys and values so can look up stored currency string and get currency
3231 (hash-for-each (lambda (key val)
3232 (hash-set! currency-lookup-hash val key))
3233 currency-type-hash)
3234 ))
3235 )
3236 );; end of define - get-periods-results
3237
3238(define (calculate-delta list-thekeys)
3239 (for-each
3240 (lambda (trans)
3241 (let (
3242 (row (get-row-in-array trans)))
3243 (array-set! amounts-array
3244 (gnc-numeric-sub
3245 (gnc:gnc-monetary-amount (get-monetary trans 1))
3246 (gnc:gnc-monetary-amount (get-monetary trans 2)) GNC-DENOM-AUTO GNC-RND-ROUND)
3247 row 3)))
3248 list-thekeys)
3249)
3250
3251
3252 (gnc:report-starting reportname)
3253(if (not (or (null? c_account_1) (and-map not c_account_1)))
3254 (begin
3255 (let* (
3256 ;; step 4 of 4 needed for gnctimeperiod-utilities
3257;; the let needs to be a let*
3258;; may need to change op-value to get-option
3259 (whichperiod-val (opt-val the_tab text-whichperiod))
3260
3261 (cust-start-date-tp (gnc:timepair-start-day-time
3262 (gnc:date-option-absolute-time
3263 (opt-val the_tab
3264 custom-from-date))))
3265
3266 (cust-end-date-tp (gnc:timepair-end-day-time
3267 (gnc:date-option-absolute-time
3268 (opt-val the_tab
3269 custom-to-date))))
3270 (year-val (opt-val the_tab text-pick-year))
3271 (period-val (opt-val the_tab text-period))
3272 (last-val (opt-val the_tab text-last))
3273 (month-val (opt-val the_tab text-month))
3274 (datelist (gnc:getdates
3275 (list whichperiod-val year-val period-val last-val month-val)) )
3276 ;;
3277 ;; replace following two names with your names and comment out your old definitions
3278 (begindate (if (equal? whichperiod-val 'customdates )
3279 cust-start-date-tp
3280 (car datelist)))
3281
3282
3283 (enddate (if (equal? whichperiod-val 'customdates )
3284 cust-end-date-tp
3285 (cadr datelist)))
3286
3287 (list-base-period (gnc:getdatedelta ;use to get number of days in base
3288 (list begindate enddate 'none)))
3289
3290;; end of section 4 needed for using gnctimeperiod-utilities
3291;;
3292 ; (begindate (gnc:timepair-start-day-time
3293 ; (gnc:date-option-absolute-time
3294 ; (opt-val pagename-general "Start Date"))))
3295 ; (enddate (gnc:timepair-end-day-time
3296 ; (gnc:date-option-absolute-time
3297 ; (opt-val pagename-general "End Date"))))
3298
3299; for comparison period
3300
3301 (deltas-val (opt-val pagename-compare text-compare-divide))
3302 (whichperiod-val2 (opt-val pagename-compare text-whichcompareperiod))
3303 (cust-start-date2-tp (gnc:timepair-start-day-time
3304 (gnc:date-option-absolute-time
3305 (opt-val pagename-compare
3306 custom-from-date))))
3307
3308 (cust-end-date2-tp (gnc:timepair-end-day-time
3309 (gnc:date-option-absolute-time
3310 (opt-val pagename-compare
3311 custom-to-date))))
3312 (year-val2 (opt-val pagename-compare text-pick-year))
3313 (period-val2 (opt-val pagename-compare text-period))
3314 (last-val2 (opt-val pagename-compare text-last))
3315 (month-val2 (opt-val pagename-compare text-month))
3316 (datelist2 (gnc:getdates
3317 (list whichperiod-val2 year-val2 period-val2 last-val2 month-val2)) )
3318 (average-val2 (opt-val pagename-compare text-average))
3319 (averagelist2 (getdates-average average-val2 (opt-val pagename-compare text-exclude-average)))
3320 ;;
3321 ;; replace following two names with your names and comment out your old definitions
3322 (begindate2 (if (equal? whichperiod-val2 'customdates )
3323 cust-start-date2-tp
3324 (if (equal? whichperiod-val2 'average )
3325 (car averagelist2)
3326 (car datelist2))))
3327
3328
3329 (enddate2 (if (equal? whichperiod-val2 'customdates )
3330 cust-end-date2-tp
3331 (if (equal? whichperiod-val2 'average )
3332 (cadr averagelist2)
3333 (cadr datelist2))))
3334 (list-of-periods (gnc:getdatedelta
3335 (list begindate2 enddate2 deltas-val)))
3336
3337;; end for comparison period
3338
3339 (primary-key (opt-val pagename-sorting optname-prime-sortkey))
3340 (primary-order (opt-val pagename-sorting "Primary Sort Order"))
3341 (secondary-key (opt-val pagename-sorting optname-sec-sortkey))
3342 (secondary-order (opt-val pagename-sorting "Secondary Sort Order"))
3343
3344;for consolidate
3345 (primary-comp-key (cdr (assq primary-key sort-key-number )))
3346 (secondary-comp-key (cdr (assq secondary-key sort-key-number )))
3347 (consolidate-case-sensitive? (opt-val pagename-display optname-consolidate-case-sensitive))
3348
3349;for compare
3350 (compare? (opt-val pagename-compare optname-compare?))
3351 (base? (or (not (opt-val pagename-compare optname-no-base?))
3352 (not (opt-val pagename-compare optname-compare?))))
3353 )
3354
3355 (set! show-days? (opt-val pagename-display optname-days))
3356
3357 (set! show-average? (opt-val pagename-compare optname-show-average?))
3358
3359;for consolidate
3360 (set! comm-curr? (opt-val pagename-general optname-common-currency))
3361 (set! curr (opt-val pagename-general optname-currency))
3362 (set! sort-date-type (let (
3363 ( primary-type (if (equal? primary-key 'date)
3364 (cdr (assq (opt-val pagename-sorting optname-prime-date-subtotal) timeperiods ))
3365 5)) ;no date requirement
3366 (sec-type (if (equal? secondary-key 'date)
3367 (assq-ref timeperiods (opt-val pagename-sorting optname-sec-date-subtotal) )
3368 5)) ;no date requirement
3369 )
3370 (min primary-type sec-type )))
3371;;end section for consolidate
3372
3373;;for scaling
3374 (set! scale-op-val (opt-val the_tab "Scale Results"))
3375 (set! scale-num-val (opt-val the_tab "Scale Number Option"))
3376
3377
3378;; for compare period scaling
3379 (set! scale-op-val2 (opt-val pagename-compare "Scale Results"))
3380 (set! scale-num-val2 (opt-val pagename-compare "Scale Number Option"))
3381
3382 (set! compare-scale-automatically? (opt-val pagename-compare optname-scale-automatically?))
3383 (set! compare-scale-to-val (opt-val pagename-compare optname-scale-to))
3384 (set! scaled? (if (or (not (= 1 scale-num-val)) (not (= 1 scale-num-val2)) compare-scale-automatically?)
3385 #t
3386 #f))
3387
3388 ;; for find option
3389 ;for find
3390 (set! find-text? (opt-val pagename-sorting optname-find-text?))
3391 (set! find1-field (cdr (assq (opt-val pagename-sorting optname-find1-field ) find-field-number )))
3392 (set! find2-operand (opt-val pagename-sorting optname-find2-operand))
3393 (set! find1-text (string-upcase (opt-val pagename-sorting optname-find1-text)))
3394 (set! find2-field (cdr (assq (opt-val pagename-sorting optname-find2-field ) find-field-number )))
3395 (set! find2-text (string-upcase (opt-val pagename-sorting optname-find2-text)))
3396
3397 (set! find-min? (opt-val pagename-sorting optname-find-min))
3398 (set! find-max? (opt-val pagename-sorting optname-find-max))
3399 (set! find-min (opt-val pagename-sorting "Min Amount"))
3400 (set! find-max (opt-val pagename-sorting "Max Amount"))
3401 (set! description-titlecase? (opt-val pagename-display optname-descript-titlecase))
3402 (set! do-find? (or find-text? find-min? find-max?) )
3403 (set! do-findamount? (or find-min? find-max?))
3404 (set! findtitle "")
3405 (if (or find-text? find-min? find-max?)
3406 (let* ( (report-currency (if comm-curr?
3407 curr
3408 (gnc-default-currency))))
3409
3410 (begin
3411 (if find-text?
3412 (begin
3413 (set! findtitle (string-append findtitle text-containing find1-text))
3414 (if (not (equal? find2-operand 'none))
3415 (set! findtitle (string-append findtitle " "
3416 (if (equal? find2-operand 'and)
3417 text-and
3418 (if (equal? find2-operand 'or)
3419 text-or
3420 (if (equal? find2-operand 'not)
3421 text-but-not
3422 "")))
3423 find2-text)))
3424 ))
3425 (if find-min?
3426 (begin
3427 (set! findtitle (string-append findtitle text-minimum (gnc:monetary->string
3428 (gnc:make-gnc-monetary report-currency
3429 (gnc:make-gnc-numeric (inexact->exact (* 100 find-min)) 100) ))))
3430 (set! find-min (* 100 find-min))
3431 ))
3432 (if find-max?
3433 (begin
3434 (set! findtitle (string-append findtitle text-maximum (gnc:monetary->string
3435 (gnc:make-gnc-monetary report-currency
3436 (gnc:make-gnc-numeric (inexact->exact (* 100 find-max)) 100) ))))
3437 (set! find-max (* 100 find-max))
3438 ))
3439 )))
3440
3441 (set! pointer-hash (make-hash-table))
3442 (set! amounts-array (make-array (gnc:html-make-empty-cell) 3000 415))
3443 (set! guid-array (make-array #f 3000 415))
3444 (set! row-number 2) ; row 0 heading row 1 number of days in the period
3445 (set! last-column 1)
3446 (set! period-number 1)
3447 (set! currency-type-hash (make-hash-table))
3448 (set! currency-lookup-hash (make-hash-table))
3449 (set! currency-type-num 1)
3450 (set! currency-type-str (number->string currency-type-num))
3451
3452; The following few lines are main section where query for data and store in array
3453
3454 ;get transactions for the specified period
3455
3456 (get-periods-results begindate enddate); get base periods transactions - results stored in list_of_trans and 2 arrays
3457 (set! amounts-array (make-array (gnc-numeric-zero) (+ (length list_of_trans) 2000) (+ (length list-of-periods) 20)))
3458 (set! guid-array (make-array #f (+ (length list_of_trans) 2000) (+ (length list-of-periods) 20)))
3459 (array-set! amounts-array ;store time period title
3460 (if compare?
3461 (display-date-interval-columns begindate enddate)
3462 "")
3463 0 last-column)
3464 (array-set! amounts-array (caddr (car list-base-period)) 1 last-column) ; store number of days
3465 (let (
3466 (scaling-mul-val
3467 (if compare-scale-automatically?
3468 compare-scale-to-val
3469 (if (eq? scale-op-val '* )
3470 scale-num-val
3471 1)))
3472 (scaling-div-val (if compare-scale-automatically?
3473 (caddr (car list-base-period))
3474 (if (eq? scale-op-val '/ )
3475 scale-num-val
3476 1)))
3477 )
3478 (if base?
3479 (store-period-values last-column list_of_trans scaling-mul-val scaling-div-val)
3480 (set! last-column 0))
3481 )
3482 ;; for calculating average
3483 (if show-average?
3484 (let* (
3485 (date-start begindate2 );(gnc:decrement-date (car dates) 0))
3486 (date-end enddate2)
3487 (num-periods (length list-of-periods))
3488 (avg-num-days (round (/ (caddr (car (gnc:getdatedelta (list begindate2 enddate2 'none)))) num-periods)))
3489
3490 (scaling-mul-val
3491 (if compare-scale-automatically?
3492 compare-scale-to-val
3493 (if (eq? scale-op-val2 '* )
3494 scale-num-val2
3495 1)))
3496 (scaling-div-val (if compare-scale-automatically?
3497 (* avg-num-days num-periods)
3498 (if (eq? scale-op-val2 '/ )
3499 (* scale-num-val2 num-periods)
3500 num-periods))) ;; need to divide to get average
3501 )
3502
3503 (set! last-column (+ last-column 1))
3504 (array-set! amounts-array
3505 (sprintf #f (_ "Average for %s %s ending %s") ;store time period title
3506 (number->string (length list-of-periods))
3507 deltas-val
3508 (gnc-print-date date-end))
3509 0 last-column)
3510 (get-periods-results date-start date-end)
3511 (array-set! amounts-array avg-num-days 1 last-column) ;store number of days
3512 (store-period-values last-column list_of_trans scaling-mul-val scaling-div-val)
3513
3514 ;; calculate delta
3515 (let (
3516 ;; pointer-hash contains all of the transactions and what row in the array they are stored in
3517 ;; convert to list named list-thekeys
3518 (list-thekeys (hash-map->list cons pointer-hash)))
3519 (calculate-delta list-thekeys)
3520 (array-set! amounts-array "Delta" 0 3)
3521 (set! last-column 4)
3522 (array-set! amounts-array "" 0 4)
3523 )
3524 ))
3525
3526 ;;
3527;; compare period is divided up into smaller parts based on users selection
3528;; for loop reads in and stores as column in array each small period
3529 (if compare?
3530 (for-each
3531 (lambda (dates)
3532 (let (
3533 (date-start (car dates) );(gnc:decrement-date (car dates) 0))
3534 (date-end (cadr dates))
3535 (scaling-mul-val
3536 (if compare-scale-automatically?
3537 compare-scale-to-val
3538 (if (eq? scale-op-val2 '* )
3539 scale-num-val2
3540 1)))
3541 (scaling-div-val (if compare-scale-automatically?
3542 (caddr dates)
3543 (if (eq? scale-op-val2 '/ )
3544 scale-num-val2
3545 1)))
3546 )
3547
3548 (set! last-column (+ last-column 1))
3549 (array-set! amounts-array
3550 (display-date-interval-columns date-start date-end) ;store time period title
3551 0 last-column)
3552 (get-periods-results date-start date-end)
3553 (array-set! amounts-array (caddr dates) 1 last-column) ;store number of days
3554 (store-period-values last-column list_of_trans scaling-mul-val scaling-div-val)
3555 ))
3556 list-of-periods)
3557 )
3558
3559(if (not (= row-number 2)) ;if row number is greater than 2 then some entries were found
3560 (let (
3561 ;; pointer-hash contains all of the transactions and what row in the array they are stored in
3562 ;; convert to list named list-thekeys
3563 (list-thekeys (hash-map->list cons pointer-hash)))
3564
3565 ; if only two periods, calculate delta
3566 (if (= last-column 2)
3567 (begin
3568 (calculate-delta list-thekeys)
3569 (set! last-column 3)
3570 (array-set! amounts-array "Delta" 0 3)
3571 )
3572 )
3573
3574 (let* (
3575
3576 ; sort based on primary and secondary keys
3577 (sort-type (get-sort-type primary-key secondary-key))
3578 (var-p (comp-sort-helper sort-type 0))
3579 (comp-p1 (comp-sort-helper sort-type 1))
3580 (comp-p2 (if (equal? primary-order 'ascend)
3581 (comp-sort-helper sort-type 2)
3582 (comp-sort-helper sort-type 3)
3583 ))
3584 (var-s (comp-sort-helper sort-type 4))
3585 (comp-s1 (comp-sort-helper sort-type 5))
3586 (comp-s2 (if (equal? secondary-order 'ascend)
3587 (comp-sort-helper sort-type 6)
3588 (comp-sort-helper sort-type 7)
3589 ))
3590 )
3591 (set! list_of_trans list_of_trans)
3592 (set! list-thekeys (sortkeys list-thekeys var-p var-s comp-p1 comp-p2 comp-s1 comp-s2))
3593 )
3594
3595
3596
3597
3598
3599 (if (> (length list-thekeys) 0)
3600 (begin
3601
3602 (let ((table
3603 (make-split-table-comp
3604 list-thekeys
3605 options
3606 primary-comp-key secondary-comp-key
3607 (comp-get-subtotal-pred optname-prime-sortkey
3608 optname-prime-subtotal
3609 optname-prime-date-subtotal)
3610 (comp-get-subtotal-pred optname-sec-sortkey
3611 optname-sec-subtotal
3612 optname-sec-date-subtotal)
3613 (comp-get-subheading-renderer optname-prime-sortkey
3614 optname-prime-subtotal
3615 optname-prime-date-subtotal)
3616 (comp-get-subheading-renderer optname-sec-sortkey
3617 optname-sec-subtotal
3618 optname-sec-date-subtotal)
3619 (comp-get-subtotal-renderer optname-prime-sortkey
3620 optname-prime-subtotal
3621 optname-prime-date-subtotal)
3622 (comp-get-subtotal-renderer optname-sec-sortkey
3623 optname-sec-subtotal
3624 optname-sec-date-subtotal))
3625 )
3626 )
3627
3628 (gnc:html-document-set-title! document
3629 (string-append consolidated-text " " report-title) )
3630 (gnc:html-document-add-object!
3631 document
3632 (gnc:make-html-text
3633 (gnc:html-markup-h3
3634 (if compare?
3635 (display-find findtitle)
3636 (display-date-interval-find begindate enddate findtitle)))))
3637
3638 (if scaled? ; for scaling
3639 (gnc:html-document-add-object!
3640 document
3641 (gnc:make-html-text
3642 (gnc:html-markup-h2
3643 (string-append scaling-text " " ))))
3644 )
3645
3646;;
3647
3648 ;;optional section for troubeshooting gnctimeperiod-utilities
3649 ;; change to (equal? 1 1) to see variables
3650 ;; use (equal? 1 "a") to hide variables
3651 (if (equal? 1 "a") ;;
3652 (begin
3653 (set! period-val " ")
3654 (let* (
3655
3656 (numtransact (length list-thekeys ))
3657
3658 (count 0)
3659 )
3660
3661 (while (< count numtransact )
3662 (begin
3663 ; get string for 1st payee (set! firstpayee (car (list-ref total-payee-get-alist 0)))
3664 ; get number for 1st amount (set! firstamount (cdr (list-ref total-payee-get-alist 0)))
3665
3666 (let* (
3667
3668 (well (if #t
3669 "match"
3670 "no_match"))
3671
3672 (current-trans (list-ref list-thekeys count ))
3673 (next-one (if (< count (- numtransact 1 ))
3674 (list-ref list-thekeys (+ count 1))
3675 current-trans))
3676
3677 (thekey (car (list-ref list-thekeys count ) ))
3678 (namcode (get-namecode current-trans))
3679 (othernam (get-other-name current-trans))
3680 (description (get-description current-trans))
3681 (amount (get-array-value-num-base current-trans))
3682 ; (amount (get-row-in-array current-trans))
3683 (amou (cdr current-trans))
3684 (accountguid (get-accountguid current-trans))
3685
3686 ; (tp (get-date-tp current-trans))
3687
3688
3689
3690 ; (comp-timepair-same-year tp-a tp-b)
3691 ; (wellm (if (comp-timepair-same-week (get-date-tp current-trans) (get-date-tp next-one))
3692 ; "match"
3693 ; "no"))
3694 ; (currencyz (gnc-default-currency))
3695 ; (currency-frac (gnc-commodity-get-fraction currencyz))
3696 )
3697
3698 (set! period-val (string-append period-val
3699 " "
3700 (number->string count)
3701 ; (txn (xaccSplitGetParent split))
3702 ; (splitcount (xaccTransCountSplits txn)
3703 "hg"
3704 "guid:"
3705 accountguid
3706 "date:"
3707 ; (strftime "%Y%m%d" (get-date-tm current-trans))
3708 " "
3709 well
3710 "Prim:"
3711 (get-primary-key current-trans)
3712 "Sec:"
3713 (get-secondary-key current-trans)
3714 "row"
3715 (number->string amount)
3716 "row1"
3717 (number->string amou)
3718 "namcod"
3719 namcode
3720 " "
3721 othernam
3722 "descrip"
3723 description
3724 ; "currency type"
3725 ; (get-currency-type current-trans)
3726 "the_key"
3727 thekey
3728 " "
3729 " "
3730 "num 12 "
3731 (if (equal? month-val2 '4)
3732 "four"
3733 "three")
3734
3735 "end test"
3736 )))
3737 (set! count (+ count 1))
3738 ))
3739 )
3740 (gnc:html-document-add-object!
3741 ;; may need to change next line or not include these 4-5 lines when adding gnctimeperiod-utilities
3742 document
3743 (gnc:make-html-text
3744
3745 (gnc:html-markup-p
3746 (gnc:html-markup/format
3747 (_ "The Pick which period option is %s.")
3748 (gnc:html-markup-b whichperiod-val)))
3749
3750
3751
3752
3753 ; (gnc:html-markup-p
3754 ; (gnc:html-markup/format
3755 ; (_ "Number of items in the list is %s.")
3756 ; (gnc:html-markup-b (number->string (comp-sort-helper 'primary_secondary 8)) )))
3757
3758
3759 (gnc:html-markup-p
3760 (gnc:html-markup/format
3761 (_ "The custom date pick is %s .")
3762 (gnc:html-markup-b (if (equal? whichperiod-val 'customdates ) (_ "true") (_ "false")))))
3763
3764 (gnc:html-markup-p
3765 (gnc:html-markup/format
3766 (_ "The year selection is %s.")
3767 (gnc:html-markup-b year-val)))
3768
3769 (gnc:html-markup-p
3770 (gnc:html-markup/format
3771 (_ "The Pick period option is %s.")
3772 (gnc:html-markup-b period-val)))
3773
3774 (gnc:html-markup-p
3775 (gnc:html-markup/format
3776 (_ "The Pick last option is %s.")
3777 (gnc:html-markup-b last-val)))
3778
3779 (gnc:html-markup-p
3780 (gnc:html-markup/format
3781 (_ "The month period option is %s.")
3782 (gnc:html-markup-b month-val)))
3783
3784 ;; Here we print the value of the number option formatted as
3785 ;; currency. When printing currency values, you should use
3786 ;; the function (xaccPrintAmount), which is defined in
3787 ;; report-utilities. This functions will format the number
3788 ;; appropriately in the current locale. Don't try to format
3789 ;; it yourself -- it will be wrong in other locales.
3790 (gnc:html-markup-p
3791 (gnc:html-markup/format
3792 (_ "The number option formatted as currency is %s.")
3793 (gnc:html-markup-b
3794 (xaccPrintAmount
3795 (gnc:make-gnc-numeric (inexact->exact (* 100 scale-num-val)) 100)
3796 (gnc-default-print-info #f)))))
3797
3798 (gnc:html-markup-p
3799 (gnc:html-markup/format
3800 (_ "The find-text option is %s.")
3801 (gnc:html-markup-b (if find-text? (_ "true") (_ "false")))))
3802
3803 (gnc:html-markup-p
3804 (gnc:html-markup/format
3805 (_ "The find-min option is %s.")
3806 (gnc:html-markup-b (if find-min? (_ "true") (_ "false")))))
3807
3808 (gnc:html-markup-p
3809 (gnc:html-markup/format
3810 (_ "The find-max option is %s.")
3811 (gnc:html-markup-b (if find-max? (_ "true") (_ "false")))))
3812
3813 ; (gnc:html-markup-p
3814 ; (gnc:html-markup/format
3815 ; (_ "The number option is %s.")
3816 ; (gnc:html-markup-b (number->string scale-num-val))))
3817
3818 ; (gnc:html-markup-p
3819 ; (gnc:html-markup/format
3820 ; (_ "The period start is %s.")
3821 ; (gnc:html-markup-b (number->string (car start-date-tp)))))
3822
3823 ; (gnc:html-markup-p
3824 ; (gnc:html-markup/format
3825 ; (_ "The period start is %s.")
3826 ; (gnc:html-markup-b (gnc-print-date start-date-tp))))
3827
3828 ; (gnc:html-markup-p
3829 ; (gnc:html-markup/format
3830 ; (_ "The period end is %s.")
3831 ; (gnc:html-markup-b (gnc-print-date end-date-tp))))
3832
3833 )
3834 )
3835 ))
3836
3837 ;end of optional section for gnctimeperiod-utilities
3838
3839 (gnc:html-document-add-object!
3840 document
3841 table
3842 )
3843
3844
3845;; show any imbalances if option choosen
3846 (if (and (opt-val pagename-display optname-show-imbalance)
3847 ;(or (equal? primary-key 'account-name) (equal? primary-key 'account-code)
3848 ; (equal? primary-key 'amount) (equal? primary-key 'description))
3849 (not do-find?))
3850 (begin
3851 (let* (
3852 (count 0)
3853 (imbalance-val "")
3854 (accounts-imbalance (gnc:accounts-imbalance-or-orphan begindate enddate))
3855 (numtransact (length accounts-imbalance ))
3856 )
3857 (gnc:html-document-add-object!
3858 document
3859 (gnc:make-html-text
3860 (gnc:html-markup-p
3861 (gnc:html-markup/format
3862 text-dash ; Few will realize it but report will show dash if imbalance was checked for
3863 ))))
3864
3865 (while (< count numtransact )
3866 (begin
3867 (let* (
3868 (current-account (list-ref accounts-imbalance count ))
3869 )
3870 (set! imbalance-val (string-append
3871 text-note-account
3872 (gnc-account-get-full-name current-account)
3873 text-changed-in-value
3874 (gnc:monetary->string (gnc:make-gnc-monetary (xaccAccountGetCommodity current-account)
3875 (gnc:account-get-balance-interval current-account begindate enddate #f)))
3876 ))
3877 (set! count (+ count 1))
3878 )
3879 (gnc:html-document-add-object!
3880 document
3881 (gnc:make-html-text
3882 (gnc:html-markup-p
3883 (gnc:html-markup/format
3884 (_ " %s")
3885 (gnc:html-markup-b imbalance-val)))
3886 ))
3887 ))
3888 )))
3889;end for showing imbalance
3890
3891
3892 ))))
3893 ;; error condition: no splits found
3894;(if (not (or (null? c_account_1) (and-map not c_account_1)))
3895 ; (begin
3896 (let ((p (gnc:make-html-text)))
3897 (gnc:html-text-append!
3898 p
3899 (gnc:html-markup-h2
3900 (_ "No matching transactions found"))
3901 (gnc:html-markup-p
3902 (_ "No transactions were found that \
3903match the time interval and account selection specified, \
3904and find requirements \
3905in the Options panel.")))
3906 (gnc:html-document-add-object! document p))
3907; ))
3908)))
3909
3910
3911 ;; error condition: no accounts specified
3912
3913 (gnc:html-document-add-object!
3914 document
3915 (gnc:html-make-no-account-warning
3916 report-title (gnc:report-id report-obj))
3917 ))
3918 (gnc:report-finished)
3919 document)
3920 )
3921
3922;; Define the report.
3923(gnc:define-report
3924
3925 'version 1
3926
3927 'name reportname
3928 'report-guid "4ce3b9833af044abb929a8dbda59620f"
3929
3930 'options-generator trep-options-generator
3931
3932 'renderer trep-renderer)