-
Notifications
You must be signed in to change notification settings - Fork 760
/
investment-lots.scm
2039 lines (1862 loc) · 80.8 KB
/
investment-lots.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;; -*-scheme-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; investment-lots.scm
;; by Brent McBride (mcbridebt@hotmail.com) Nov 2022
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash reports standard investment-lots))
(use-modules (ice-9 format))
(use-modules (ice-9 match))
(use-modules (gnucash app-utils))
(use-modules (gnucash core-utils)) ;for gnc-prefs-is-extra-enabled
(use-modules (gnucash engine))
(use-modules (gnucash html))
(use-modules (gnucash report))
(use-modules (gnucash utilities))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-11)) ;for let-values
(use-modules (srfi srfi-13)) ;for string-trim
(define pagename-chart (N_ "Chart"))
(define pagename-columns (N_ "Columns"))
(define pagename-validation (N_ "Validation"))
;; Accounts
(define optname-accounts (N_ "Accounts"))
(define optname-zero-shares (N_ "Include accounts with no shares"))
(define optname-include-lotless-accounts (N_ "Include accounts with no lots"))
;; Chart
(define optname-show-chart (N_ "Show Chart"))
(define optname-chart-type (N_ "Chart type"))
(define optname-chart-location (N_ "Chart location"))
(define optname-plot-width (N_ "Plot width"))
(define optname-plot-height (N_ "Plot height"))
;; Columns
(define optname-show-lot-guid-column (N_ "Show lot guid column"))
(define optname-show-date-columns (N_ "Show date columns"))
(define optname-show-bought-columns (N_ "Show bought columns"))
(define optname-show-sold-columns (N_ "Show sold columns"))
(define optname-show-end-columns (N_ "Show end columns"))
(define optname-show-realized-gain-columns
(N_ "Show realized gain column(s)"))
(define optname-show-unrealized-gain-columns
(N_ "Show unrealized gain column(s)"))
(define optname-group-gains-by-age
(N_ "Group gains by age (short term and long term)"))
(define optname-long-term-years (N_ "Long term gains age (years)"))
;; Display
(define optname-show-long-account-names (N_ "Show long account names"))
(define optname-show-mnemonics (N_ "Show mnemonic in amounts"))
(define optname-include-closed-lots (N_ "Include closed lots"))
(define optname-show-blanks-for-zeros
(N_ "Show blanks instead of zeros in table cells"))
(define optname-show-split-rows (N_ "Show lot split rows"))
;; General
(define reportname (N_ "Investment Lots"))
(define optname-from-date (N_ "Start date"))
(define optname-to-date (N_ "End date"))
(define optname-report-currency (N_ "Report's currency"))
(define optname-price-source (N_ "Price source"))
;; Warnings
(define optname-include-only-accounts-with-warnings
(N_ "Include only accounts with warnings"))
(define optname-warn-if-multiple-bought-splits
(N_ "Warn if a lot has more than one bought split"))
(define optname-warn-if-balance-negative
(N_ "Warn if a lot's balance drops below zero"))
(define optname-warn-if-lot-title-blank
(N_ "Warn if a lot has a blank title"))
(define optname-warn-if-gains-mismatch
(N_ "Warn if the 'Realized Gain/Loss' split(s) sum does not match the computed gains"))
(define optname-warn-type-if-split-not-in-lot
(N_ "Warn if a split is not assigned to a lot"))
(define optname-warn-if-balance-mismatch
(N_ "Warn if the account balance does not match the computed lots' end balance"))
(define colname-lot-title (N_ "Lot Title"))
(define colname-opened (N_ "Opened"))
(define colname-closed (N_ "Closed"))
(define colname-lot-guid (N_ "GUID"))
(define colname-bought-amount (N_ "Bought Amount"))
(define colname-bought-value (N_ "Bought Value (Basis)"))
(define colname-bought-price (N_ "Bought Average Price"))
(define colname-sold-splits (N_ "Sold Splits"))
(define colname-sold-amount (N_ "Sold Amount"))
(define colname-sold-basis (N_ "Sold Basis"))
(define colname-sold-value (N_ "Sold Value"))
(define colname-short-term-sold-amount (N_ "ST Sold Amount"))
(define colname-short-term-sold-basis (N_ "ST Sold Basis"))
(define colname-short-term-sold-value (N_ "ST Sold Value"))
(define colname-long-term-sold-amount (N_ "LT Sold Amount"))
(define colname-long-term-sold-basis (N_ "LT Sold Basis"))
(define colname-long-term-sold-value (N_ "LT Sold Value"))
(define colname-sold-price (N_ "Sold Average Price"))
(define colname-end-amount (N_ "End Amount"))
(define colname-end-basis (N_ "End Basis"))
(define colname-end-value (N_ "End Value"))
(define colname-realized-gain (N_ "Realized Gain"))
(define colname-short-term-realized-gain (N_ "ST Realized Gain"))
(define colname-long-term-realized-gain (N_ "LT Realized Gain"))
(define colname-realized-roi (N_ "Realized ROI"))
(define colname-unrealized-gain (N_ "Unrealized Gain"))
(define colname-short-term-unrealized-gain (N_ "ST Unrealized Gain"))
(define colname-long-term-unrealized-gain (N_ "LT Unrealized Gain"))
(define colname-unrealized-roi (N_ "Unrealized ROI"))
(define label-account-total (N_ "Account Lots Total"))
(define label-grand-total (N_ "Grand Total"))
;; This function will generate a set of options that GnuCash
;; will use to display a dialog where the user can select
;; values for the report's parameters.
(define (options-generator)
(let* ((options (gnc-new-optiondb)))
;; Accounts tab
(gnc-register-account-list-limited-option options
gnc:pagename-accounts
optname-accounts
"a"
(N_ "Stock Accounts to report on.")
;; default-getter
(filter gnc:account-is-stock?
(gnc-account-get-descendants-sorted
(gnc-get-current-root-account)))
(list ACCT-TYPE-STOCK ACCT-TYPE-MUTUAL))
(gnc-register-simple-boolean-option options
gnc:pagename-accounts
optname-zero-shares
"b"
(N_ "Include accounts that have a zero share balances.")
#t)
(gnc-register-simple-boolean-option options
gnc:pagename-accounts
optname-include-lotless-accounts
"c"
(N_ "Include accounts with no lots")
#f)
;; Chart tab
(gnc-register-simple-boolean-option options
pagename-chart
optname-show-chart
"a"
(N_ "Include a chart that shows lot gains, grouped by account and gain type")
#t)
(gnc-register-multichoice-option options
pagename-chart
optname-chart-type
"b"
(N_ "What kind of chart to include")
"bar-stacked"
(list (vector 'bar (N_ "Bar Chart"))
(vector 'bar-stacked (N_ "Stacked Bar Chart"))))
(gnc-register-multichoice-option options
pagename-chart
optname-chart-location
"c"
(N_ "Where to place the chart")
"top"
(list (vector 'top (N_ "Top"))
(vector 'bottom (N_ "Bottom"))))
(gnc:options-add-plot-size!
options
pagename-chart
optname-plot-width
optname-plot-height
"d"
(cons 'percent 100.0)
(cons 'percent 50.0))
;; Columns tab
(gnc-register-simple-boolean-option options
pagename-columns
optname-show-lot-guid-column
"a"
(N_ "Show the lot GUID table column")
#f)
(gnc-register-simple-boolean-option options
pagename-columns
optname-show-date-columns
"b"
(N_ "Show the lot open and close table columns")
#t)
(gnc-register-simple-boolean-option options
pagename-columns
optname-show-bought-columns
"c"
(N_ "Show purchase-related table columns")
#t)
(gnc-register-simple-boolean-option options
pagename-columns
optname-show-sold-columns
"d"
(N_ "Show sale-related table columns")
#t)
(gnc-register-simple-boolean-option options
pagename-columns
optname-show-end-columns
"e"
(N_ "Show end date amount and value table columns")
#t)
(gnc-register-simple-boolean-option options
pagename-columns
optname-show-realized-gain-columns
"f"
(N_ "Show realized gain table column(s) for sold shares")
#t)
(gnc-register-simple-boolean-option options
pagename-columns
optname-show-unrealized-gain-columns
"g"
(N_ "Show unrealized gain table column(s) for unsold shares")
#t)
(gnc-register-multichoice-callback-option options
pagename-columns
optname-group-gains-by-age
"h"
(N_ "Group gains (and sales?) by long-term (LT) and short-term (ST)")
"gains-only"
(list (vector 'no (N_ "No"))
(vector 'gains-only (N_ "Gains Only"))
(vector 'gains-and-sales (N_ "Gains and Sales")))
(lambda (x)
(gnc-optiondb-set-option-selectable-by-name
options pagename-columns optname-long-term-years
(not (eq? x 'no)))))
;; Note: Different governments may have different rules regarding how long
;; shares must be held to qualify for different tax treatment. So make
;; configurable the boundary between short-term and long-term capital
;; gains.
(gnc-register-number-range-option options
pagename-columns
optname-long-term-years
"i"
(N_ "Commodities held longer than this many years count as long-term (LT).")
1 ;; default-value. For USA federal taxes, shares held longer than 1
;; year are long-term.
0 ;; lower-bound
10E9 ;; upper-bound
1) ;; step-size
;; Display tab
(gnc-register-simple-boolean-option options
gnc:pagename-display
optname-show-long-account-names
"a"
(N_ "Show long (instead of short) account names")
#t)
(gnc-register-simple-boolean-option options
gnc:pagename-display
optname-show-mnemonics
"b"
(N_ "Show mnemonics with commodity amounts")
#t)
(gnc-register-simple-boolean-option options
gnc:pagename-display
optname-include-closed-lots
"c"
(N_ "Include closed lots in addition to open lots")
#t)
(gnc-register-simple-boolean-option options
gnc:pagename-display
optname-show-blanks-for-zeros
"d"
(N_ "Show blank text instead of zero values for inner table cells. Does not apply to footer rows.")
#t)
(gnc-register-simple-boolean-option options
gnc:pagename-display
optname-show-split-rows
"e"
(N_ "Add a row for each split belonging to a lot, under the lot row.")
#f)
;; General tab
(gnc:options-add-date-interval!
options gnc:pagename-general optname-from-date optname-to-date "a")
(gnc:options-add-currency!
options
gnc:pagename-general
optname-report-currency
"b")
(gnc-register-multichoice-option options
gnc:pagename-general
optname-price-source
"c" (N_ "The source of price information.") "pricedb-before"
(list (vector 'pricedb-before (N_ "Last up through report date"))
(vector 'pricedb-nearest (N_ "Closest to report date"))
(vector 'pricedb-latest (N_ "Most recent"))))
;; Validation tab
(gnc-register-simple-boolean-option options
pagename-validation
optname-include-only-accounts-with-warnings
"a"
(N_ "Only show accounts that contain warnings. This is useful for quickly finding potential lot errors.")
#f)
(gnc-register-simple-boolean-option options
pagename-validation
optname-warn-if-multiple-bought-splits
"b"
(N_ "Lots with more than one purchase split are not well formed. It may make ambiguous the capital gains age")
#t)
(gnc-register-simple-boolean-option options
pagename-validation
optname-warn-if-balance-negative
"c"
(N_ "Lots with a negative balance are not well formed.")
#t)
(gnc-register-simple-boolean-option options
pagename-validation
optname-warn-if-lot-title-blank
"d"
(N_ "Lot titles are optional. This warning applies to titles that are empty or only whitespace.")
#f) ;; Defaulting to false, since lot titles are not required.
(gnc-register-simple-boolean-option options
pagename-validation
optname-warn-if-gains-mismatch
"e"
(N_ "Detect possible errors in 'Realized Gain/Loss' splits that are created when adding a sale split to a lot")
#t)
(gnc-register-multichoice-option options
pagename-validation
optname-warn-type-if-split-not-in-lot
"f" (N_ "Detect splits that have not been assigned to a lot.") "count"
(list (vector 'no (N_ "No"))
(vector 'count (N_ "Count"))
(vector 'list (N_ "List"))))
(gnc-register-simple-boolean-option options
pagename-validation
optname-warn-if-balance-mismatch
"g"
(N_ "Balance mismatches may indicate a split that is not yet included in a lot")
#t)
options))
;; This is the rendering function. It accepts a database of options
;; and generates an object of type <html-document>. See the file
;; report-html.txt for documentation; the file report-html.scm
;; includes all the relevant Scheme code. The option database passed
;; to the function is one created by the options-generator function
;; defined above.
(define (investment-lots-renderer report-obj)
;; This is a helper function for looking up option values.
(define (get-option section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
;; Given a price list and a currency find the price for that currency on the
;; list. If there is none for the requested currency, return the first one.
(define (find-price price-list currency)
(if (eqv? price-list '())
#f
(let loop ((price-list price-list)
(first-price (car price-list)))
(match price-list
(() first-price)
((price . rest)
(cond
((gnc-commodity-equiv currency (gnc-price-get-currency price))
price)
((gnc-commodity-equiv currency (gnc-price-get-commodity price))
(gnc-price-invert price))
(else
(loop rest first-price))))))))
(let* (;; Accounts options
(accounts (get-option gnc:pagename-accounts optname-accounts))
(include-empty-accounts
(get-option gnc:pagename-accounts optname-zero-shares))
(include-lotless-accounts
(get-option gnc:pagename-accounts
optname-include-lotless-accounts))
;; Chart options
(show-chart (get-option pagename-chart optname-show-chart))
(chart-type (get-option pagename-chart optname-chart-type))
(chart-location (get-option pagename-chart optname-chart-location))
(chart-height (get-option pagename-chart optname-plot-height))
(chart-width (get-option pagename-chart optname-plot-width))
;; Column options
(show-lot-guid-column
(get-option pagename-columns optname-show-lot-guid-column))
(show-date-columns
(get-option pagename-columns optname-show-date-columns))
(show-bought-columns
(get-option pagename-columns optname-show-bought-columns))
(show-sold-columns
(get-option pagename-columns optname-show-sold-columns))
(show-end-columns
(get-option pagename-columns optname-show-end-columns))
(show-realized-gain-columns
(get-option pagename-columns optname-show-realized-gain-columns))
(show-unrealized-gain-columns
(get-option pagename-columns
optname-show-unrealized-gain-columns))
(group-gains-and-sales-by-age
(get-option pagename-columns optname-group-gains-by-age))
(long-term-years
(get-option pagename-columns optname-long-term-years))
;; Display options
(include-closed-lots
(get-option gnc:pagename-display optname-include-closed-lots))
(show-long-account-names
(get-option gnc:pagename-display optname-show-long-account-names))
(show-mnemonics
(get-option gnc:pagename-display optname-show-mnemonics))
(show-blanks-for-zeros
(get-option gnc:pagename-display optname-show-blanks-for-zeros))
(show-split-rows
(get-option gnc:pagename-display optname-show-split-rows))
;; General options
(from-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(get-option gnc:pagename-general optname-from-date))))
(to-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(get-option gnc:pagename-general optname-to-date))))
(report-currency (get-option gnc:pagename-general
optname-report-currency))
(price-source (get-option gnc:pagename-general
optname-price-source))
;; Validation options
(include-only-accounts-with-warnings
(get-option pagename-validation
optname-include-only-accounts-with-warnings))
(warn-if-multiple-bought-splits
(get-option pagename-validation
optname-warn-if-multiple-bought-splits))
(warn-if-balance-negative
(get-option pagename-validation optname-warn-if-balance-negative))
(warn-if-lot-title-blank
(get-option pagename-validation optname-warn-if-lot-title-blank))
(warn-if-gains-mismatch
(get-option pagename-validation optname-warn-if-gains-mismatch))
(warn-type-if-split-not-in-lot
(get-option pagename-validation
optname-warn-type-if-split-not-in-lot))
(warn-if-balance-mismatch
(get-option pagename-validation optname-warn-if-balance-mismatch))
(warn-if-split-not-in-lot
(not (eq? warn-type-if-split-not-in-lot 'no)))
(group-gains-by-age
(not (eq? group-gains-and-sales-by-age 'no)))
(group-sales-by-age
(eq? group-gains-and-sales-by-age 'gains-and-sales))
(report-currency-fraction
(gnc-commodity-get-fraction report-currency))
(price-db (gnc-pricedb-get-db (gnc-get-current-book)))
(price-fn
(case price-source
((pricedb-latest)
(lambda (commodity)
(find-price
(gnc-pricedb-lookup-latest-any-currency
price-db commodity)
report-currency)))
((pricedb-nearest)
(lambda (commodity)
(find-price
(gnc-pricedb-lookup-nearest-in-time-any-currency-t64
price-db commodity
(time64CanonicalDayTime to-date))
report-currency)))
((pricedb-before)
(lambda (commodity)
(find-price
(gnc-pricedb-lookup-nearest-before-any-currency-t64
price-db commodity
(time64CanonicalDayTime to-date))
report-currency)))))
(exchange-fn (gnc:case-exchange-fn
price-source
report-currency
to-date))
(get-report-value-zero (lambda ()
(gnc-numeric-create 0 report-currency-fraction)))
;; Note: To the user, the report appears to contain a vertical list
;; of tables, one per investment account. But these account tables
;; are actually implemented as a single html table, with empty spacer
;; rows inserted between. Using a single table keeps the columns
;; aligned, which makes the report easier to read.
(table (gnc:make-html-table))
(chart (if show-chart
(gnc:make-html-chart)))
(colors (gnc:assign-colors (length accounts)))
(document (gnc:make-html-document)))
;; Returns whether a commodity purchased on bought-date and sold on
;; sold-date qualifies for long-term capital gains treatment. The boundary
;; between short and long term is configurable, but otherwise this logic
;; is USA federal government-specific, as per
;; https://www.irs.gov/publications/p550#en_US_2021_publink100010540:
;;
;; "If you hold investment property more than 1 year, any capital gain or
;; loss is a long-term capital gain or loss. If you hold the property 1
;; year or less, any capital gain or loss is a short-term capital gain or
;; loss. To determine how long you held the investment property, begin
;; counting on the date after the day you acquired the property. The day
;; you disposed of the property is part of your holding period."
(define (long-term? bought-date sold-date)
(if (and bought-date
(not (null? bought-date))
sold-date
(not (null? sold-date)))
;; Note: gnc:date-year-delta handles the complexity of dealing with
;; leap years.
(let ((years-held (gnc:date-year-delta bought-date sold-date)))
(> years-held long-term-years))
#f))
;; Gets the account name.
(define (account->name account)
(if show-long-account-names
(gnc-account-get-full-name account)
(xaccAccountGetName account)))
;; Gets anchor linked to the account, with the account name as anchor
;; text.
(define (to-account-anchor account)
(gnc:html-markup-anchor
(gnc:account-anchor-text account)
(account->name account)))
;; Gets a formatted display string for the given currency and amount, e.g.
;; "$(1,000.21)"
(define (amount->monetary-string currency amount)
(xaccPrintAmount
amount
(gnc-commodity-print-info currency show-mnemonics)))
;; Gets the lot title.
(define (lot->title lot)
(gnc-lot-get-title lot))
;; Gets the lot guid.
(define (lot->guid lot)
(if lot
(gncLotReturnGUID lot)
#f))
;; Gets the split's transaction date.
(define (split->date split)
(xaccTransGetDate (xaccSplitGetParent split)))
;; Gets an html table cell containing the value, formatted as a number
;; (i.e. right justified, etc.)
;; is-total determines whether total cell styling (i.e. bold) is used.
(define (to-number-cell value is-total)
(gnc:make-html-table-cell/markup
(if is-total "total-number-cell" "number-cell")
(cond
((integer? value)
(format #f "~d" value)) ;; convert to string to not show decimals.
(else value))))
;; Gets an html table cell containing the value, formatted as a column
;; header.
(define (to-header-cell value)
(gnc:make-html-table-cell/markup "column-heading-center" value))
;; Gets an html table cell containing an anchor with the specified text
;; and that links to the specified split.
(define (to-split-cell text split)
(if text
(to-number-cell
(if split
(gnc:html-split-anchor split text)
text)
#f) ;; is-total
#f))
;; Returns the given value in the given currency, converted to the
;; report's currency.
(define (value->report-currency-value value currency)
(gnc:gnc-monetary-amount
(exchange-fn
(gnc:make-gnc-monetary
currency
value) ;; foreign
report-currency))) ;; domestic
;; Gets a gnc-monetary for the given value and the report currency.
(define (value->monetary value)
(gnc:make-gnc-monetary report-currency value))
;; Gets the display string for value, formatted as the report's currency,
;; e.g. "$(1,000.21)".
(define (value->monetary-string value)
(xaccPrintAmount
value
(gnc-commodity-print-info report-currency #t))) ;; show-mnemonics
;; Gets all splits for the given account, bounded by to-date. Splits
;; before from-date are also included (needed to calculate running
;; balance and basis during the report date window).
(define (get-all-splits account)
(let ((query (qof-query-create-for-splits)))
(qof-query-set-book query (gnc-get-current-book))
(xaccQueryAddClearedMatch query
(logand CLEARED-ALL (lognot CLEARED-VOIDED)) QOF-QUERY-AND)
(xaccQueryAddSingleAccountMatch query account QOF-QUERY-AND)
(xaccQueryAddDateMatchTT query
#f ; use_start.
0 ; start. Note: Intentionally not using from-date.
#t ; use-end
to-date QOF-QUERY-AND)
(let ((result (qof-query-run query)))
(qof-query-destroy query)
(gnc:debug (format #f "Found ~a splits." (length result)))
result)))
;; Returns a pair where the first item is a list of lots for the given
;; splits. The second item is the number of splits that are not assigned
;; to a lot.
(define (get-all-lots splits)
(define lots-seen (make-hash-table))
(let loop ((splits splits)
(lots '())
(unassigned-splits '()))
(match splits
(()
(gnc:debug (format #f "Found ~a lots and ~a unassigned splits"
(length lots)
(length unassigned-splits)))
(list (reverse lots) unassigned-splits))
((split . rest)
(let ((lot (xaccSplitGetLot split)))
(loop rest
(cond
((or (null? lot)
(hash-ref lots-seen lot))
lots)
(else
(hash-set! lots-seen lot #t)
(cons lot lots)))
(cond
((null? lot)
(cons split unassigned-splits))
(else unassigned-splits))))))))
;; Returns the lot splits, ordered first by transaction date and then
;; ordering purchases before sales.
(define (lot->splits lot)
(sort-list!
;; Prune out splits that are after to-date.
(let loop ((splits (gnc-lot-get-split-list lot))
(result '()))
(match splits
(() result)
((split . rest)
(loop rest
(if (<= (split->date split) to-date)
(cons split result)
result)))))
(lambda (s1 s2)
(let* ((t1 (xaccSplitGetParent s1))
(t2 (xaccSplitGetParent s2))
(date1 (xaccTransGetDate t1))
(date2 (xaccTransGetDate t2))
;; Do not call xaccTransOrder to set t-order. It not only
;; sorts by date posted, but by other fields that we don't
;; care about here (i.e. num, date entered, description, and
;; guid). When two transactions have the same date, we want
;; t-order to be zero, regardless of those other fields, so
;; that the secondary sorting logic (purchase or sale) takes
;; effect.
;; (t-order (xaccTransOrder t1 t2))
(t-order (cond
((< date1 date2) -1)
((> date1 date2) 1)
(else 0))))
(if (= t-order 0)
;; The two splits share the same transaction date. Order
;; purchases before sales.
(let ((is-purchase-s1
(gnc-numeric-positive-p (xaccSplitGetAmount s1)))
(is-purchase-s2
(gnc-numeric-positive-p (xaccSplitGetAmount s2))))
(cond
((and is-purchase-s1 is-purchase-s2)
;; They are both purchases and on the same date. So go
;; ahead and let xaccTransOrder be the tiebreaker (not
;; that it matters much).
(<= (xaccTransOrder t1 t2) 0))
(else is-purchase-s1)))
(<= t-order 0))))))
;; Gets the price's time.
(define (price->time price)
(gnc-price-get-time64 price))
;; Gets the price's value.
(define (price->value price)
(gnc-price-get-value price))
;; Gets the price's currency.
(define (price->currency price)
(gnc-price-get-currency price))
;; Gets the price's guid.
(define (price->guid price)
(gncPriceGetGUID price))
;; Gets a gnc-monetary with the price's currency and value.
(define (price->monetary price)
(gnc:make-gnc-monetary
(price->currency price)
(price->value price)))
;; Returns the given price's value, converted to the
;; report's currency, if different.
(define (price->report-currency-value price)
(value->report-currency-value
(price->value price)
(price->currency price)))
;; Returns the given price as a formatted string, in the report's
;; currency.
(define (price->report-currency-monetary-string price)
(value->monetary-string (price->report-currency-value price)))
;; Returns the given price as an anchor whose text is the formatted
;; value and that links to the price editor.
(define (to-price-anchor price)
(if (and (not (null? price))
price
(price->guid price))
(gnc:html-markup/format
(N_ " End price: ~a~a on ~a")
(gnc:html-markup-anchor
(gnc-build-url URL-TYPE-PRICE
(string-append "price-guid=" (price->guid price))
"")
(price->monetary price))
(if (not (gnc-commodity-equiv report-currency
(price->currency price)))
;; The price is not already in the report currency, so also
;; display the price converted to the report currency.
(format #f (G_ " [~a]")
(price->report-currency-monetary-string price))
"")
(qof-print-date (price->time price)))
(N_ "No price found")))
;; Gets the average price (i.e. value/amount). Returns 0 if the equation
;; is undefined (i.e. protects against divide by zero errors.) Returns
;; #f if either amount or value are #f.
(define (get-average-price amount value)
(if (and
amount
value)
(if (gnc-numeric-zero-p amount)
(get-report-value-zero)
(gnc-numeric-div value amount GNC-DENOM-AUTO GNC-DENOM-REDUCE))
#f))
;; Gets a list of visible table column headers. Note that report options
;; control which columns to show. Also, some column headers will be blank
;; for the grand total header (such as amount columns, since multiple
;; accounts may have different commodities, so combining their amounts
;; would not make sense).
(define (get-column-header-list is-grand-total)
(append
(list (if is-grand-total #f colname-lot-title))
(if show-lot-guid-column
(list (if is-grand-total #f colname-lot-guid))
'())
(if show-date-columns
(list
(if is-grand-total #f colname-opened)
(if is-grand-total #f colname-closed))
'())
(if show-bought-columns
(list
(if is-grand-total #f colname-bought-amount)
colname-bought-value
(if is-grand-total #f colname-bought-price))
'())
(if show-sold-columns
(append
(list colname-sold-splits)
(if group-sales-by-age
(list
(if is-grand-total #f colname-short-term-sold-amount)
colname-short-term-sold-basis
colname-short-term-sold-value
(if is-grand-total #f colname-long-term-sold-amount)
colname-long-term-sold-basis
colname-long-term-sold-value)
(list
(if is-grand-total #f colname-sold-amount)
colname-sold-basis
colname-sold-value))
(list (if is-grand-total #f colname-sold-price))
)
'())
(if show-end-columns
(list
(if is-grand-total #f colname-end-amount)
colname-end-basis
colname-end-value)
'())
(if show-realized-gain-columns
(if group-gains-by-age
(list
colname-short-term-realized-gain
colname-long-term-realized-gain
colname-realized-roi)
(list
colname-realized-gain
colname-realized-roi))
'())
(if show-unrealized-gain-columns
(if group-gains-by-age
(list
colname-short-term-unrealized-gain
colname-long-term-unrealized-gain
colname-unrealized-roi)
(list
colname-unrealized-gain
colname-unrealized-roi))
'())))
;; The number of table columns.
(define column-count (length (get-column-header-list #f))) ;is-grand-total
;; Gets the row style for even/odd rows.
(define (get-row-style is-odd-row)
(if is-odd-row "normal-row" "alternate-row"))
;; Adds a header row to table.
(define (add-header-row table is-grand-total)
(gnc:html-table-append-row/markup!
table
"normal-row"
(map to-header-cell
(get-column-header-list is-grand-total))))
;; Adds a warning row to table.
(define (add-warning-row table warning)
(let ((cell
(gnc:make-html-table-cell/size
1 ;; rowspan
column-count ;; colspan
;; If the warning is a string then convert it to html text.
;; Otherwise, use it as-is.
(if (string? warning)
(gnc:make-html-text warning)
warning)))
;; If the warning is not plain text, indent it.
(indent? (not (string? warning))))
(gnc:html-table-cell-set-style!
cell "td"
'attribute
(list "class" (string-append
"total-label-cell neg" ;; bold, red, left justified
(if indent? " indented" ""))))
(gnc:html-table-append-row! table (list cell))))
;; Copies the rows (with their styles) from one table to another
;; table. If row-style is provided, it is used instead of copying the
;; source row's style.
(define (copy-table-rows from-table to-table row-style)
(let loop ((row-num 0)
(rows (reverse (gnc:html-table-data from-table))))
(match rows
(() #f)
((row . rest)
(gnc:html-table-append-row/markup! to-table
(or row-style
(gnc:html-table-row-markup from-table row-num)) row)
(loop (+ row-num 1) rest)))))
;; Adds a data row to table.
(define (add-data-row
table
amount-currency
is-bold
is-odd-row
first-text
lot
open-date-cell
close-date-cell
bought-amount
bought-value
sold-split-count
short-term-sold-amount
short-term-sold-basis
short-term-sold-value
long-term-sold-amount
long-term-sold-basis
long-term-sold-value
end-amount
end-basis
end-value
short-term-realized-gain
long-term-realized-gain
short-term-unrealized-gain
long-term-unrealized-gain)
;; Helper function for converting a numeric value to an html table cell.
(define (to-cell val format-val-fn)
(if (or (not val)
(and (not is-bold) ;; total rows are bold. Don't replace zeros.
show-blanks-for-zeros
(= val 0)))
#f ;; show a blank cell
(to-number-cell
(format-val-fn)
is-bold)))
;; Converts a value (denominated in the account's commodity) to an html
;; table cell.
(define (amount->cell amount)
(to-cell
amount
(lambda ()
(amount->monetary-string amount-currency amount))))
;; Converts an integer to an html table cell.
(define (integer->cell number)
(to-cell
number
(lambda () number)))
(define (percentage->cell number)
;; This formats negative percentages similar to numbers: red with
;; parentheses. But other reports don't do that? Better to be
;; consistent. Plus the below logic is kludgy.
;; (let* ((neg? (< number 0))
;; (text (if neg?
;; (format #f "(~,1f%)" (- 0 number))
;; (format #f "~,1f%" number)))
;; (style (if is-bold "total-number-cell" "number-cell")))
;; (if neg?
;; (set! style (string-append style "-neg")))
;; (if (and (not is-bold) ;; Don't replace zeros for total rows.
;; show-blanks-for-zeros
;; (= val 0))