gnucash stable: Multiple changes pushed
John Ralls
jralls at code.gnucash.org
Sat Jun 27 12:49:33 EDT 2026
Updated via https://github.com/Gnucash/gnucash/commit/1d744065 (commit)
via https://github.com/Gnucash/gnucash/commit/ec97ca60 (commit)
from https://github.com/Gnucash/gnucash/commit/b57349e8 (commit)
commit 1d744065f1a945a1cda698d38e2c77b3eccb5192
Merge: b57349e83d ec97ca6029
Author: John Ralls <jralls at ceridwen.us>
Date: Sat Jun 27 09:48:25 2026 -0700
Merge Brent McBride's 'Investment-lot-CAGR-columns' into stable.
commit ec97ca6029a0d451b3389456c743ab68e9f7b9da
Author: Brent McBride <mcbridebt at hotmail.com>
Date: Wed Jun 17 22:52:54 2026 -0700
Add CAGR columns to Investment Lots report
Add compound annual growth rate (CAGR) columns to the Investment Lots report, refactor the split-handling logic, and expand the test-investment-lots SRFI-64 suite to cover the new calculations and reverse-split regression cases.
diff --git a/gnucash/report/reports/standard/investment-lots.scm b/gnucash/report/reports/standard/investment-lots.scm
index 40a897fcd3..7d38425637 100644
--- a/gnucash/report/reports/standard/investment-lots.scm
+++ b/gnucash/report/reports/standard/investment-lots.scm
@@ -60,12 +60,14 @@
(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)"))
+ (N_ "Show realized gain columns"))
(define optname-show-unrealized-gain-columns
- (N_ "Show unrealized gain column(s)"))
+ (N_ "Show unrealized gain columns"))
(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)"))
+(define optname-show-roi-columns (N_ "Show ROI columns"))
+(define optname-show-cagr-columns (N_ "Show CAGR columns"))
;; Display
(define optname-show-long-account-names (N_ "Show long account names"))
@@ -123,10 +125,12 @@
(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-realized-cagr (N_ "Realized CAGR"))
(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 colname-unrealized-cagr (N_ "Unrealized CAGR"))
(define label-account-total (N_ "Account Lots Total"))
(define label-grand-total (N_ "Grand Total"))
@@ -135,7 +139,18 @@
;; 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)))
+ (let ((options (gnc-new-optiondb)))
+
+ ;; When both realized and unrealized gain columns are hidden, the gain
+ ;; percentage columns (ROI and CAGR) won't be visible anyways, so disable
+ ;; their corresponding options.
+ (define (update-gain-percentage-columns-enabled enabled)
+ (for-each
+ (lambda (name)
+ (gnc-optiondb-set-option-selectable-by-name options
+ pagename-columns name enabled))
+ (list optname-show-roi-columns
+ optname-show-cagr-columns)))
;; Accounts tab
(gnc-register-account-list-limited-option options
@@ -207,7 +222,7 @@
(cons 'percent 50.0))
;; Columns tab
- (gnc-register-simple-boolean-option options
+ (gnc-register-simple-boolean-option options
pagename-columns
optname-show-lot-guid-column
"a"
@@ -242,19 +257,29 @@
(N_ "Show end date amount and value table columns")
#t)
- (gnc-register-simple-boolean-option options
+ (gnc-register-complex-boolean-option options
pagename-columns
optname-show-realized-gain-columns
"f"
(N_ "Show realized gain table column(s) for sold shares")
- #t)
+ #t
+ (lambda (x)
+ (update-gain-percentage-columns-enabled
+ (or x (gnc-optiondb-lookup-value options
+ pagename-columns
+ optname-show-unrealized-gain-columns)))))
- (gnc-register-simple-boolean-option options
+ (gnc-register-complex-boolean-option options
pagename-columns
optname-show-unrealized-gain-columns
"g"
(N_ "Show unrealized gain table column(s) for unsold shares")
- #t)
+ #t
+ (lambda (x)
+ (update-gain-percentage-columns-enabled
+ (or x (gnc-optiondb-lookup-value options
+ pagename-columns
+ optname-show-realized-gain-columns)))))
(gnc-register-multichoice-callback-option options
pagename-columns
@@ -285,6 +310,20 @@
10E9 ;; upper-bound
1) ;; step-size
+ (gnc-register-simple-boolean-option options
+ pagename-columns
+ optname-show-roi-columns
+ "j"
+ (N_ "Show Return On Investment (ROI) columns")
+ #f)
+
+ (gnc-register-simple-boolean-option options
+ pagename-columns
+ optname-show-cagr-columns
+ "k"
+ (N_ "Show Compound Annual Growth Rate (CAGR) columns")
+ #t)
+
;; Display tab
(gnc-register-simple-boolean-option options
gnc:pagename-display
@@ -325,6 +364,14 @@
(gnc:options-add-date-interval!
options gnc:pagename-general optname-from-date optname-to-date "a")
+ ;; Use a default report date of 'today'. Otherwise,
+ ;; 'end of accounting period' would be the default. A future date
+ ;; makes a poor default because they may result in misleading/non-sensical
+ ;; unrealized CAGR percentages.
+ (GncOption-set-default-value
+ (gnc-lookup-option options gnc:pagename-general optname-to-date)
+ 'today)
+
(gnc:options-add-currency!
options
gnc:pagename-general
@@ -392,6 +439,165 @@
options))
+;; Calculate Compound Annual Growth Rate (CAGR)
+;; basis: starting value (numeric or false)
+;; end-value: ending value (numeric)
+;; years: holding period in years (numeric or false)
+;; Returns: decimal (0.0 = 0% gain, 1.0 = 100% gain), or #f if undefined
+(define (calculate-cagr basis end-value years)
+ "Calculate compound annual growth rate.
+Returns #f if calculation is not possible, otherwise returns decimal CAGR."
+ (if (or (eq? basis #f)
+ (gnc-numeric-zero-p basis)
+ (gnc-numeric-negative-p basis)
+ (gnc-numeric-negative-p end-value)
+ (eq? years #f)
+ (zero? years))
+ #f
+ (- (expt (/ (gnc-numeric-to-double end-value)
+ (gnc-numeric-to-double basis))
+ (/ 1 years))
+ 1)))
+
+;; Calculate simple gain or loss
+;; basis: cost basis (numeric)
+;; end-value: current or sale value (numeric)
+;; Returns: gain/loss as gnc-numeric
+(define (calculate-gain basis end-value)
+ "Calculate gain or loss.
+Returns gnc-numeric value of gain or loss."
+ (gnc-numeric-sub-fixed end-value basis))
+
+;; Calculate return on investment (ROI) percentage
+;; basis: cost basis (numeric)
+;; gain: realized or unrealized gain (numeric)
+;; Returns: decimal (0.0 = 0%, 1.0 = 100%), or #f if undefined
+(define (calculate-roi basis gain)
+ "Calculate return on investment percentage.
+Returns decimal percentage (0.0 = 0%, 1.0 = 100%), or #f if zero basis."
+ (if (gnc-numeric-zero-p basis)
+ #f
+ (/ (gnc-numeric-to-double gain)
+ (gnc-numeric-to-double basis))))
+
+;; Determine if a holding qualifies as long-term based on holding period
+;; buy-date: acquisition date (time64)
+;; sell-date: sale or valuation date (time64)
+;; long-term-years: threshold in years
+;; Returns: #t if held >= long-term-years, #f otherwise
+(define (is-long-term? buy-date sell-date long-term-years)
+ "Determine if holding period qualifies as long-term.
+Returns #t if held >= long-term-years, #f otherwise."
+ (let* ((seconds-per-day 86400)
+ (days-per-year 365.25)
+ (days-held (/ (- sell-date buy-date) seconds-per-day))
+ (years-held (/ days-held days-per-year)))
+ (>= years-held long-term-years)))
+
+;; Compute aggregate gain metrics used by renderer formatting.
+;; Returns list: (total-gain roi-percent cagr-percent)
+(define (compute-gain-metrics basis short-gain long-gain cagr-value)
+ (let* ((total-gain (gnc-numeric-add-fixed short-gain long-gain))
+ (roi-decimal
+ (cond
+ ((or (not basis)
+ (not total-gain))
+ #f)
+ ((gnc-numeric-zero-p basis)
+ 0)
+ (else (calculate-roi basis total-gain))))
+ (roi-percent (and roi-decimal (* 100 roi-decimal)))
+ (cagr-percent (and cagr-value (* 100 cagr-value))))
+ (list total-gain roi-percent cagr-percent)))
+
+;; True when split metadata indicates a stock split event.
+(define (stock-split-event? split-type split-action)
+ (or (and split-type (string=? split-type "stock-split"))
+ (and split-action (string-ci=? split-action "split"))))
+
+;; True for reverse stock split style share reductions: negative amount,
+;; zero value, and stock split metadata. These are non-realizing events and
+;; should not affect realized gains or basis.
+(define (non-realizing-share-reduction?
+ split-type split-action amount value)
+ (and (stock-split-event? split-type split-action)
+ (gnc-numeric-negative-p amount)
+ (gnc-numeric-zero-p value)))
+
+;; Classify a split event for lot processing.
+(define (classify-lot-split split-type split-action amount value)
+ (cond
+ ((non-realizing-share-reduction?
+ split-type split-action amount value)
+ 'non-realizing-share-reduction)
+ ((gnc-numeric-positive-p amount) 'purchase)
+ ((gnc-numeric-negative-p amount) 'sale)
+ ((gnc-numeric-zero-p amount) 'realized-gain-split)
+ (else 'other)))
+
+;; Returns a pair-like list: (lots unassigned-splits)
+;; where lots are unique lots referenced by splits.
+(define (collect-lots-and-unassigned-splits splits)
+ (define lots-seen (make-hash-table))
+ (let loop ((remaining splits)
+ (lots '())
+ (unassigned-splits '()))
+ (match remaining
+ (()
+ (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 #t when s1 should sort before s2 for lot processing:
+;; first by transaction date, then purchases before sales on same date.
+(define (split-sort<=? s1 s2)
+ (let* ((t1 (xaccSplitGetParent s1))
+ (t2 (xaccSplitGetParent s2))
+ (date1 (xaccTransGetDate t1))
+ (date2 (xaccTransGetDate t2))
+ (date-order (cond
+ ((< date1 date2) -1)
+ ((> date1 date2) 1)
+ (else 0))))
+ (if (= date-order 0)
+ (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)
+ ;; Same-day purchases: defer to transaction ordering as tiebreak.
+ (<= (xaccTransOrder t1 t2) 0))
+ (else is-purchase-s1)))
+ (<= date-order 0))))
+
+;; Returns lot splits up to and including to-date, sorted consistently.
+(define (lot-splits-up-to-date lot to-date)
+ (sort-list!
+ (let loop ((remaining (gnc-lot-get-split-list lot))
+ (result '()))
+ (match remaining
+ (() result)
+ ((split . rest)
+ (let ((split-date (xaccTransGetDate (xaccSplitGetParent split))))
+ (loop rest
+ (if (<= split-date to-date)
+ (cons split result)
+ result))))))
+ split-sort<=?))
+
;; 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
@@ -402,8 +608,7 @@
;; 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)))
+ (gnc-optiondb-lookup-value (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.
@@ -434,7 +639,7 @@
;; 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-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))
@@ -458,6 +663,10 @@
(get-option pagename-columns optname-group-gains-by-age))
(long-term-years
(get-option pagename-columns optname-long-term-years))
+ (show-roi-columns
+ (get-option pagename-columns optname-show-roi-columns))
+ (show-cagr-columns
+ (get-option pagename-columns optname-show-cagr-columns))
;; Display options
(include-closed-lots
@@ -578,6 +787,11 @@
(> years-held long-term-years))
#f))
+ ;; Returns the Compound Annual Growth Rate (CAGR). Returns false if basis
+ ;; and/or years are zero or false.
+ (define (get-cagr basis end-value years)
+ (calculate-cagr basis end-value years))
+
;; Gets the account name.
(define (account->name account)
(if show-long-account-names
@@ -683,77 +897,18 @@
;; 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))))))))
+ (let* ((result (collect-lots-and-unassigned-splits splits))
+ (lots (car result))
+ (unassigned-splits (cadr result)))
+ (gnc:debug (format #f "Found ~a lots and ~a unassigned splits"
+ (length lots)
+ (length unassigned-splits)))
+ result))
;; 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))))))
+ (lot-splits-up-to-date lot to-date))
;; Gets the price's time.
(define (price->time price)
@@ -830,6 +985,28 @@
;; accounts may have different commodities, so combining their amounts
;; would not make sense).
(define (get-column-header-list is-grand-total)
+
+ ;; Helper function for getting the list of gains-related column names.
+ (define (get-gains-column-header-list
+ colname-short-term-gain
+ colname-long-term-gain
+ colname-gain
+ colname-roi
+ colname-cagr)
+ (append
+ (if group-gains-by-age
+ (list
+ colname-short-term-gain
+ colname-long-term-gain)
+ (list
+ colname-gain))
+ (if show-roi-columns
+ (list colname-roi)
+ '())
+ (if show-cagr-columns
+ (list
+ (if is-grand-total #f colname-cagr))
+ '())))
(append
(list (if is-grand-total #f colname-lot-title))
(if show-lot-guid-column
@@ -871,24 +1048,20 @@
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))
+ (get-gains-column-header-list
+ colname-short-term-realized-gain
+ colname-long-term-realized-gain
+ colname-realized-gain
+ colname-realized-roi
+ colname-realized-cagr)
'())
(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))
+ (get-gains-column-header-list
+ colname-short-term-unrealized-gain
+ colname-long-term-unrealized-gain
+ colname-unrealized-gain
+ colname-unrealized-roi
+ colname-unrealized-cagr)
'())))
;; The number of table columns.
@@ -965,8 +1138,10 @@
end-value
short-term-realized-gain
long-term-realized-gain
+ realized-cagr
short-term-unrealized-gain
- long-term-unrealized-gain)
+ long-term-unrealized-gain
+ unrealized-cagr)
;; Helper function for converting a numeric value to an html table cell.
(define (to-cell val format-val-fn)
(if (or (not val)
@@ -1022,29 +1197,33 @@
(value->monetary value))))
;; Helper function for adding capital gains columns
- (define (get-gains-fn show-columns basis short-gain long-gain)
+ (define (get-gains-fn show-columns basis short-gain long-gain cagr-value)
(append
(if show-columns
- (let* ((total-gain (gnc-numeric-add-fixed
- short-gain
- long-gain))
- (roi (percentage->cell
- (cond
- ((or (not basis)
- (not total-gain))
- #f)
- ((gnc-numeric-zero-p basis)
- 0)
- (else
- (* 100 (/ total-gain basis)))))))
- (if group-gains-by-age
- (list
- (value->cell short-gain)
- (value->cell long-gain)
- roi)
- (list
- (value->cell total-gain)
- roi)))
+ (let* ((gain-metrics
+ (compute-gain-metrics
+ basis
+ short-gain
+ long-gain
+ cagr-value))
+ (total-gain (car gain-metrics))
+ (roi-percent (cadr gain-metrics))
+ (cagr-percent (caddr gain-metrics))
+ (roi (percentage->cell roi-percent))
+ (cagr (percentage->cell cagr-percent)))
+ (append
+ (if group-gains-by-age
+ (list
+ (value->cell short-gain)
+ (value->cell long-gain))
+ (list
+ (value->cell total-gain)))
+ (if show-roi-columns
+ (list roi)
+ '())
+ (if show-cagr-columns
+ (list cagr)
+ '())))
'())))
(if is-bold
@@ -1113,12 +1292,14 @@
show-realized-gain-columns
sold-basis
short-term-realized-gain
- long-term-realized-gain)
+ long-term-realized-gain
+ realized-cagr)
(get-gains-fn
show-unrealized-gain-columns
end-basis
short-term-unrealized-gain
- long-term-unrealized-gain))))
+ long-term-unrealized-gain
+ unrealized-cagr))))
(gnc:html-table-append-row/markup!
table
(if is-bold "grand-total" (get-row-style is-odd-row))
@@ -1163,12 +1344,14 @@
(long-term-sold-basis (get-report-value-zero))
(long-term-sold-value (get-report-value-zero))
(long-term-realized-gain (get-report-value-zero))
+ (weighted-realized-cagr 0.0)
(end-amount (get-amount-zero))
(end-basis (get-report-value-zero))
(end-value (get-report-value-zero))
(unrealized-gain (get-report-value-zero))
(short-term-unrealized-gain (get-report-value-zero))
(long-term-unrealized-gain (get-report-value-zero))
+ (weighted-unrealized-cagr 0.0)
(has-warnings #f)
(is-active-in-window #f)
(currency '())
@@ -1221,7 +1404,8 @@
sold-basis
sold-value
sold-gain
- is-long-term)
+ is-long-term
+ cagr)
(if show-split-rows
(let ((date-cell
(to-split-cell (qof-print-date trans-date) split))
@@ -1260,8 +1444,10 @@
(if (and is-long-term sold-gain) 0 sold-gain)
;; long-term-realized-gain
(if (and is-long-term sold-gain) sold-gain 0)
+ cagr ;; realized-cagr
#f ;; short-term-unrealized-gain
- #f)))) ;; long-term-unrealized-gain
+ #f ;; long-term-unrealized-gain
+ #f)))) ;; unrealized-cagr
;; Adds the stats to the given html table.
(define (add-to-table table is-odd-row)
@@ -1287,7 +1473,32 @@
(cond
(is-lot-row (lot->title lot))
(is-account-row label-account-total)
- (is-grand-total-row label-grand-total))))
+ (is-grand-total-row label-grand-total)))
+ (years-held
+ (cond
+ (is-lot-row
+ (gnc:date-year-delta
+ latest-bought-split-date
+ to-date))
+ (else #f)))
+ (unrealized-cagr
+ (cond
+ (is-lot-row (get-cagr end-basis end-value years-held))
+ (is-account-row
+ (if (gnc-numeric-zero-p end-amount)
+ 0
+ (/ weighted-unrealized-cagr end-amount)))
+ (is-grand-total-row #f)))
+ (sold-amount (gnc-numeric-add-fixed
+ long-term-sold-amount
+ short-term-sold-amount))
+ (realized-cagr
+ (cond
+ ((or is-lot-row is-account-row)
+ (if (gnc-numeric-zero-p sold-amount)
+ 0
+ (/ weighted-realized-cagr sold-amount)))
+ (is-grand-total-row #f))))
(add-data-row
table
(if (not is-grand-total-row) currency #f)
@@ -1311,11 +1522,18 @@
end-value
short-term-realized-gain
long-term-realized-gain
+ (if (not is-grand-total-row) realized-cagr #f)
short-term-unrealized-gain
- long-term-unrealized-gain)
+ long-term-unrealized-gain
+ (if (not is-grand-total-row) unrealized-cagr #f))
(if is-lot-row
- (copy-table-rows splits-table table (get-row-style is-odd-row)))
+ (begin
+ (if unrealized-cagr
+ (set! weighted-unrealized-cagr
+ (+ weighted-unrealized-cagr
+ (* unrealized-cagr end-amount))))
+ (copy-table-rows splits-table table (get-row-style is-odd-row))))
(add-warnings-to-table table)
@@ -1513,28 +1731,99 @@
(xaccSplitGetValue split)
trans-currency))
(amount (xaccSplitGetAmount split))
- (is-purchase (gnc-numeric-positive-p amount))
- (is-sale (gnc-numeric-negative-p amount))
- (is-realized-gain (gnc-numeric-zero-p amount)))
+ (split-type (xaccSplitGetType split))
+ (split-action (xaccSplitGetAction split))
+ (split-kind
+ (classify-lot-split split-type split-action amount value)))
- (cond
- (is-purchase
+ (case split-kind
+ ((purchase)
(merge-purchase-split split trans-date amount value))
- (is-sale
+ ;; Reverse stock splits (or equivalent metadata-tagged share
+ ;; reductions) are non-realizing events: shares decrease with no
+ ;; proceeds, so basis and realized gain must remain unchanged.
+ ((non-realizing-share-reduction)
+ (merge-non-realizing-share-reduction-split
+ split
+ trans-date
+ ;; Convert to positive share reduction.
+ (gnc-numeric-neg amount)))
+
+ ((sale)
(merge-sale-split
split
trans-date
- ;; Covert amount and value to positive numbers.
+ ;; Convert amount and value to positive numbers.
(gnc-numeric-neg amount)
(gnc-numeric-neg value)))
;; A "Realized Gain/Loss" split has zero amount. Sum its value
;; to validate against the report-computed gain value.
- ((and is-realized-gain
- (>= trans-date from-date))
+ ((realized-gain-split)
+ (if (>= trans-date from-date)
(set! splits-realized-gain
- (gnc-numeric-add-fixed splits-realized-gain value))))))
+ (gnc-numeric-add-fixed splits-realized-gain value))))
+
+ (else #f))))
+
+ ;; Merges in a non-realizing share reduction (e.g. reverse stock
+ ;; split). Shares are reduced, but basis and realized gains are not.
+ (define (merge-non-realizing-share-reduction-split
+ split trans-date amount)
+ (set! end-amount (gnc-numeric-sub-fixed end-amount amount))
+ (if (and (>= trans-date from-date)
+ (null? first-negative-split)
+ (gnc-numeric-negative-p end-amount))
+ (set! first-negative-split split)))
+
+ ;; Adds sale metrics into either the long-term or short-term
+ ;; accumulator buckets.
+ (define (accumulate-sale-term! is-long-term amount basis value gain)
+ (if is-long-term
+ (begin
+ (set! long-term-sold-amount
+ (gnc-numeric-add-fixed long-term-sold-amount amount))
+ (set! long-term-sold-basis
+ (gnc-numeric-add-fixed long-term-sold-basis basis))
+ (set! long-term-sold-value
+ (gnc-numeric-add-fixed long-term-sold-value value))
+ (set! long-term-realized-gain
+ (gnc-numeric-add-fixed long-term-realized-gain gain)))
+ (begin
+ (set! short-term-sold-amount
+ (gnc-numeric-add-fixed short-term-sold-amount amount))
+ (set! short-term-sold-basis
+ (gnc-numeric-add-fixed short-term-sold-basis basis))
+ (set! short-term-sold-value
+ (gnc-numeric-add-fixed short-term-sold-value value))
+ (set! short-term-realized-gain
+ (gnc-numeric-add-fixed short-term-realized-gain gain)))))
+
+ ;; Adds purchase metrics into current-window or pre-window buckets.
+ (define (accumulate-purchase! trans-date amount value)
+ (if (>= trans-date from-date)
+ (begin
+ (set! bought-amount
+ (gnc-numeric-add-fixed bought-amount amount))
+ (set! bought-value
+ (gnc-numeric-add-fixed bought-value value)))
+ (begin
+ (set! old-bought-value
+ (gnc-numeric-add-fixed old-bought-value value))
+ (set! old-bought-amount
+ (gnc-numeric-add-fixed old-bought-amount amount)))))
+
+ ;; Generic field merge helpers used by merge-stats.
+ (define (merge-fixed-field! stats get-current set-current stats-key)
+ (set-current
+ (gnc-numeric-add-fixed (get-current) (stats stats-key))))
+
+ (define (merge-double-field! stats get-current set-current stats-key)
+ (set-current (+ (get-current) (stats stats-key))))
+
+ (define (merge-boolean-or-field! stats get-current set-current stats-key)
+ (set-current (or (get-current) (stats stats-key))))
;; Merges in the sale split info.
(define (merge-sale-split split trans-date amount value)
@@ -1572,45 +1861,40 @@
(cond
((>= trans-date from-date)
- ;; Remember if a sale within the report window causes the
- ;; lot's balance to go negative.
- (if (and (null? first-negative-split)
- (gnc-numeric-negative-p end-amount))
- (set! first-negative-split split))
-
- (cond
- (is-long-term
- (set! long-term-sold-amount
- (gnc-numeric-add-fixed long-term-sold-amount amount))
- (set! long-term-sold-basis
- (gnc-numeric-add-fixed long-term-sold-basis basis))
- (set! long-term-sold-value
- (gnc-numeric-add-fixed long-term-sold-value value))
- (set! long-term-realized-gain
- (gnc-numeric-add-fixed long-term-realized-gain gain)))
- (else
- (set! short-term-sold-amount
- (gnc-numeric-add-fixed short-term-sold-amount amount))
- (set! short-term-sold-basis
- (gnc-numeric-add-fixed short-term-sold-basis basis))
- (set! short-term-sold-value
- (gnc-numeric-add-fixed short-term-sold-value value))
- (set! short-term-realized-gain
- (gnc-numeric-add-fixed short-term-realized-gain gain))))
-
- (add-split-row
- split
- trans-date
- #f ;; bought-amount
- #f ;; bought-value
- amount ;; sold-amount
- basis ;; sold-basis
- value ;; sold-value
- gain ;; sold-gain
- is-long-term)
-
- (set! sold-split-count (+ sold-split-count 1))
- (set! last-sold-split split)))))
+ (let* ((years-held
+ (gnc:date-year-delta
+ latest-bought-split-date
+ trans-date))
+ (cagr (get-cagr basis value years-held)))
+ ;; Remember if a sale within the report window causes the
+ ;; lot's balance to go negative.
+ (if (and (null? first-negative-split)
+ (gnc-numeric-negative-p end-amount))
+ (set! first-negative-split split))
+
+ ;; if CAGR could not be computed because the basis and/or the
+ ;; years held are zero (like if a security was bought and sold
+ ;; on the same day), then do not include it in the total.
+ (if cagr
+ (set! weighted-realized-cagr
+ (+ weighted-realized-cagr (* cagr amount))))
+
+ (accumulate-sale-term! is-long-term amount basis value gain)
+
+ (add-split-row
+ split
+ trans-date
+ #f ;; bought-amount
+ #f ;; bought-value
+ amount ;; sold-amount
+ basis ;; sold-basis
+ value ;; sold-value
+ gain ;; sold-gain
+ is-long-term
+ cagr)
+
+ (set! sold-split-count (+ sold-split-count 1))
+ (set! last-sold-split split))))))
;; Merges in the purchase split info.
(define (merge-purchase-split split trans-date amount value)
@@ -1631,12 +1915,13 @@
(set! latest-bought-split-date trans-date))
(set! end-basis (gnc-numeric-add-fixed end-basis value))
(set! end-amount (gnc-numeric-add-fixed end-amount amount))
+
+ ;; Always accumulate purchase totals; row rendering still depends on
+ ;; whether the purchase occurred inside the report window.
+ (accumulate-purchase! trans-date amount value)
+
(cond
((>= trans-date from-date)
- (set! bought-amount
- (gnc-numeric-add-fixed bought-amount amount))
- (set! bought-value
- (gnc-numeric-add-fixed bought-value value))
(add-split-row
split
trans-date
@@ -1646,16 +1931,13 @@
#f ;; sold-basis
#f ;; sold-value
#f ;; sold-gain
- #f)) ;; is-long-term
+ #f ;; is-long-term
+ #f)) ;; cagr
;; The split is from before the report's start date.
;; So we won't include it in the report table, but
;; we still need to count it for basis calculations.
- (else
- (set! old-bought-value
- (gnc-numeric-add-fixed old-bought-value value))
- (set! old-bought-amount
- (gnc-numeric-add-fixed old-bought-amount amount))))
+ (else #f))
;; Note that this also counts purchases before the report
;; start date.
@@ -1675,83 +1957,101 @@
(else #f))))
(set! bought-split-count
(+ bought-split-count (stats 'get-bought-split-count)))
- (set! old-bought-value
- (gnc-numeric-add-fixed
- old-bought-value
- (stats 'get-old-bought-value)))
- (set! bought-value
- (gnc-numeric-add-fixed bought-value (stats 'get-bought-value)))
- (set! sold-split-count
- (gnc-numeric-add-fixed
- sold-split-count
- (stats 'get-sold-split-count)))
- (set! short-term-sold-basis
- (gnc-numeric-add-fixed
- short-term-sold-basis
- (stats 'get-short-term-sold-basis)))
- (set! short-term-sold-value
- (gnc-numeric-add-fixed
- short-term-sold-value
- (stats 'get-short-term-sold-value)))
- (set! short-term-realized-gain
- (gnc-numeric-add-fixed
- short-term-realized-gain
- (stats 'get-short-term-realized-gain)))
- (set! long-term-sold-basis
- (gnc-numeric-add-fixed
- long-term-sold-basis
- (stats 'get-long-term-sold-basis)))
- (set! long-term-sold-value
- (gnc-numeric-add-fixed
- long-term-sold-value
- (stats 'get-long-term-sold-value)))
- (set! long-term-realized-gain
- (gnc-numeric-add-fixed
- long-term-realized-gain
- (stats 'get-long-term-realized-gain)))
- (set! end-basis
- (gnc-numeric-add-fixed end-basis (stats 'get-end-basis)))
- (set! end-value
- (gnc-numeric-add-fixed end-value (stats 'get-end-value)))
- (set! unrealized-gain
- (gnc-numeric-add-fixed
- unrealized-gain
- (stats 'get-unrealized-gain)))
- (set! short-term-unrealized-gain
- (gnc-numeric-add-fixed
- short-term-unrealized-gain
- (stats 'get-short-term-unrealized-gain)))
- (set! long-term-unrealized-gain
- (gnc-numeric-add-fixed
- long-term-unrealized-gain
- (stats 'get-long-term-unrealized-gain)))
- (set! has-warnings
- (or has-warnings
- (stats 'get-has-warnings)))
- (set! is-active-in-window
- (or is-active-in-window
- (stats 'get-is-active-in-window)))
+ (merge-fixed-field! stats
+ (lambda () old-bought-value)
+ (lambda (v) (set! old-bought-value v))
+ 'get-old-bought-value)
+ (merge-fixed-field! stats
+ (lambda () bought-value)
+ (lambda (v) (set! bought-value v))
+ 'get-bought-value)
+ (merge-fixed-field! stats
+ (lambda () sold-split-count)
+ (lambda (v) (set! sold-split-count v))
+ 'get-sold-split-count)
+ (merge-fixed-field! stats
+ (lambda () short-term-sold-basis)
+ (lambda (v) (set! short-term-sold-basis v))
+ 'get-short-term-sold-basis)
+ (merge-fixed-field! stats
+ (lambda () short-term-sold-value)
+ (lambda (v) (set! short-term-sold-value v))
+ 'get-short-term-sold-value)
+ (merge-fixed-field! stats
+ (lambda () short-term-realized-gain)
+ (lambda (v) (set! short-term-realized-gain v))
+ 'get-short-term-realized-gain)
+ (merge-fixed-field! stats
+ (lambda () long-term-sold-basis)
+ (lambda (v) (set! long-term-sold-basis v))
+ 'get-long-term-sold-basis)
+ (merge-fixed-field! stats
+ (lambda () long-term-sold-value)
+ (lambda (v) (set! long-term-sold-value v))
+ 'get-long-term-sold-value)
+ (merge-fixed-field! stats
+ (lambda () long-term-realized-gain)
+ (lambda (v) (set! long-term-realized-gain v))
+ 'get-long-term-realized-gain)
+ (merge-double-field! stats
+ (lambda () weighted-realized-cagr)
+ (lambda (v) (set! weighted-realized-cagr v))
+ 'get-weighted-realized-cagr)
+ (merge-fixed-field! stats
+ (lambda () end-basis)
+ (lambda (v) (set! end-basis v))
+ 'get-end-basis)
+ (merge-fixed-field! stats
+ (lambda () end-value)
+ (lambda (v) (set! end-value v))
+ 'get-end-value)
+ (merge-fixed-field! stats
+ (lambda () unrealized-gain)
+ (lambda (v) (set! unrealized-gain v))
+ 'get-unrealized-gain)
+ (merge-fixed-field! stats
+ (lambda () short-term-unrealized-gain)
+ (lambda (v) (set! short-term-unrealized-gain v))
+ 'get-short-term-unrealized-gain)
+ (merge-fixed-field! stats
+ (lambda () long-term-unrealized-gain)
+ (lambda (v) (set! long-term-unrealized-gain v))
+ 'get-long-term-unrealized-gain)
+ (merge-double-field! stats
+ (lambda () weighted-unrealized-cagr)
+ (lambda (v) (set! weighted-unrealized-cagr v))
+ 'get-weighted-unrealized-cagr)
+ (merge-boolean-or-field! stats
+ (lambda () has-warnings)
+ (lambda (v) (set! has-warnings v))
+ 'get-has-warnings)
+ (merge-boolean-or-field! stats
+ (lambda () is-active-in-window)
+ (lambda (v) (set! is-active-in-window v))
+ 'get-is-active-in-window)
(if include-amounts
(begin
- (set! old-bought-amount
- (gnc-numeric-add-fixed
- old-bought-amount
- (stats 'get-old-bought-amount)))
- (set! bought-amount
- (gnc-numeric-add-fixed
- bought-amount
- (stats 'get-bought-amount)))
- (set! short-term-sold-amount
- (gnc-numeric-add-fixed
- short-term-sold-amount
- (stats 'get-short-term-sold-amount)))
- (set! long-term-sold-amount
- (gnc-numeric-add-fixed
- long-term-sold-amount
- (stats 'get-long-term-sold-amount)))
- (set! end-amount
- (gnc-numeric-add-fixed end-amount (stats 'get-end-amount)))
+ (merge-fixed-field! stats
+ (lambda () old-bought-amount)
+ (lambda (v) (set! old-bought-amount v))
+ 'get-old-bought-amount)
+ (merge-fixed-field! stats
+ (lambda () bought-amount)
+ (lambda (v) (set! bought-amount v))
+ 'get-bought-amount)
+ (merge-fixed-field! stats
+ (lambda () short-term-sold-amount)
+ (lambda (v) (set! short-term-sold-amount v))
+ 'get-short-term-sold-amount)
+ (merge-fixed-field! stats
+ (lambda () long-term-sold-amount)
+ (lambda (v) (set! long-term-sold-amount v))
+ 'get-long-term-sold-amount)
+ (merge-fixed-field! stats
+ (lambda () end-amount)
+ (lambda (v) (set! end-amount v))
+ 'get-end-amount)
;; The amounts are being combined, so they must all pertain to
;; the same currency. Copy it, if not already set.
(if (null? currency)
@@ -1781,6 +2081,7 @@
((get-short-term-realized-gain)
(lambda () short-term-realized-gain))
((get-long-term-realized-gain) (lambda () long-term-realized-gain))
+ ((get-weighted-realized-cagr) (lambda () weighted-realized-cagr))
((get-end-amount) (lambda () end-amount))
((get-end-basis) (lambda () end-basis))
((get-end-value) (lambda () end-value))
@@ -1789,6 +2090,7 @@
(lambda () short-term-unrealized-gain))
((get-long-term-unrealized-gain)
(lambda () long-term-unrealized-gain))
+ ((get-weighted-unrealized-cagr) (lambda () weighted-unrealized-cagr))
((get-has-warnings) (lambda () has-warnings))
((get-is-active-in-window) (lambda () is-active-in-window))
((get-currency) (lambda () currency))
diff --git a/gnucash/report/reports/standard/test/CMakeLists.txt b/gnucash/report/reports/standard/test/CMakeLists.txt
index 49a850667e..773c0dd1d3 100644
--- a/gnucash/report/reports/standard/test/CMakeLists.txt
+++ b/gnucash/report/reports/standard/test/CMakeLists.txt
@@ -18,6 +18,7 @@ set(scm_test_with_srfi64_SOURCES
test-equity-statement.scm
test-average-balance.scm
test-ifrs-cost-basis.scm
+ test-investment-lots.scm
test-invoice.scm
test-new-owner-report.scm
test-owner-report.scm
diff --git a/gnucash/report/reports/standard/test/test-investment-lots.scm b/gnucash/report/reports/standard/test/test-investment-lots.scm
new file mode 100644
index 0000000000..e87371e755
--- /dev/null
+++ b/gnucash/report/reports/standard/test/test-investment-lots.scm
@@ -0,0 +1,836 @@
+(use-modules (tests test-engine-extras))
+(use-modules (gnucash reports standard investment-lots))
+(use-modules (gnucash report))
+(use-modules (tests test-report-extras))
+(use-modules (gnucash report stylesheets plain))
+(use-modules (tests srfi64-extras))
+(use-modules (srfi srfi-64))
+(use-modules (gnucash engine))
+(use-modules (gnucash app-utils))
+
+;; UUID for the investment-lots report
+(define uuid "ab2acc24afd14630a551f98f1a35fa81")
+
+;; Explicitly set locale to make the report output predictable
+(setlocale LC_ALL "C")
+
+;; Exercise production helper implementations directly.
+(define calculate-cagr
+ (@@ (gnucash reports standard investment-lots) calculate-cagr))
+(define calculate-gain
+ (@@ (gnucash reports standard investment-lots) calculate-gain))
+(define calculate-roi
+ (@@ (gnucash reports standard investment-lots) calculate-roi))
+(define is-long-term?
+ (@@ (gnucash reports standard investment-lots) is-long-term?))
+
+(define (run-test)
+ (test-runner-factory gnc:test-runner)
+ (test-begin "test-investment-lots")
+ (test-investment-lots)
+ (test-end "test-investment-lots"))
+
+(define (set-option! options page tag value)
+ (if (gnc-lookup-option (gnc:optiondb options) page tag)
+ (gnc-set-option (gnc:optiondb options) page tag value)
+ (begin
+ (test-assert (format #f "wrong-option ~a ~a" page tag) #f)
+ #f)))
+
+(define (options->sxml options test-title)
+ (gnc:options->sxml uuid options "test-investment-lots" test-title
+ #:strip-tag "script"))
+
+(define (render-report options test-title)
+ "Render report and return #t if successful, #f if error."
+ (catch #t
+ (lambda ()
+ (let ((result (options->sxml options test-title)))
+ (if result #t #f)))
+ (lambda (key . args)
+ #f)))
+
+(define (mnemonic->commodity sym)
+ (gnc-commodity-table-lookup
+ (gnc-commodity-table-get-table (gnc-get-current-book))
+ (gnc-commodity-get-namespace (gnc-default-report-currency))
+ sym))
+
+(define (create-investment-lots-test-data)
+ (let* ((book (gnc-get-current-book))
+ (env (create-test-env))
+ (USD (mnemonic->commodity "USD"))
+ (comm-table (gnc-commodity-table-get-table book))
+ ;; Create stock commodities
+ (AAPL (gnc-commodity-new book "Apple" "NASDAQ" "AAPL" "" 1))
+ (SPY (gnc-commodity-new book "SPY" "NYSE" "SPY" "" 1))
+ (structure
+ (list "Root" (list (cons 'type ACCT-TYPE-ASSET)
+ (cons 'commodity USD))
+ (list "Assets"
+ (list "Broker" (list (cons 'commodity USD))
+ (list "Cash" (list (cons 'commodity USD)))
+ (list "AAPL" (list (cons 'commodity AAPL)
+ (cons 'type ACCT-TYPE-STOCK)))
+ (list "SPY" (list (cons 'commodity SPY)
+ (cons 'type ACCT-TYPE-STOCK)))))
+ (list "Income" (list (cons 'type ACCT-TYPE-INCOME))))))
+
+ ;; Register commodities in the table
+ (gnc-commodity-table-insert comm-table AAPL)
+ (gnc-commodity-table-insert comm-table SPY)
+
+ (let* ((account-alist (env-create-account-structure-alist env structure))
+ (cash (cdr (assoc "Cash" account-alist)))
+ (aapl-acct (cdr (assoc "AAPL" account-alist)))
+ (spy-acct (cdr (assoc "SPY" account-alist)))
+ (income (cdr (assoc "Income" account-alist))))
+
+ ;; Create transactions forming two lots of AAPL
+ ;; Lot 1: Buy 100 shares at $50
+ (env-create-multisplit-transaction
+ env 01 01 2020
+ (list (vector cash -5000 -5000 "")
+ (vector aapl-acct 100 100 "Buy 100 shares"))
+ #:description "Buy AAPL lot 1"
+ #:currency USD)
+
+ ;; Lot 2: Buy 50 shares at $60
+ (env-create-multisplit-transaction
+ env 01 02 2020
+ (list (vector cash -3000 -3000 "")
+ (vector aapl-acct 50 50 "Buy 50 shares"))
+ #:description "Buy AAPL lot 2"
+ #:currency USD)
+
+ ;; Partial sale: 60 shares at $80
+ (env-create-multisplit-transaction
+ env 01 06 2020
+ (list (vector cash 4800 4800 "")
+ (vector aapl-acct -60 -60 "Sell 60 shares"))
+ #:description "Sell AAPL"
+ #:currency USD)
+
+ ;; Buy SPY for variety
+ (env-create-multisplit-transaction
+ env 01 01 2020
+ (list (vector cash -40000 -40000 "")
+ (vector spy-acct 200 200 "Buy 200 shares"))
+ #:description "Buy SPY"
+ #:currency USD)
+
+ account-alist)))
+
+(define (create-reverse-split-lot-test-data)
+ (let* ((book (gnc-get-current-book))
+ (env (create-test-env))
+ (USD (mnemonic->commodity "USD"))
+ (comm-table (gnc-commodity-table-get-table book))
+ (AAPL (gnc-commodity-new book "Apple" "NASDAQ" "AAPL" "" 1))
+ (structure
+ (list "Root" (list (cons 'type ACCT-TYPE-ASSET)
+ (cons 'commodity USD))
+ (list "Assets"
+ (list "Broker" (list (cons 'commodity USD))
+ (list "Cash" (list (cons 'commodity USD)))
+ (list "AAPL" (list (cons 'commodity AAPL)
+ (cons 'type ACCT-TYPE-STOCK))))))))
+
+ (gnc-commodity-table-insert comm-table AAPL)
+
+ (let* ((account-alist (env-create-account-structure-alist env structure))
+ (cash (cdr (assoc "Cash" account-alist)))
+ (aapl-acct (cdr (assoc "AAPL" account-alist)))
+ (lot (gnc-lot-new book))
+ (buy-txn (xaccMallocTransaction book))
+ (buy-stock (xaccMallocSplit book))
+ (buy-cash (xaccMallocSplit book))
+ (split-txn (xaccMallocTransaction book))
+ (split-split (xaccMallocSplit book)))
+
+ ;; Buy 100 shares into one explicit lot.
+ (xaccTransBeginEdit buy-txn)
+ (xaccTransSetCurrency buy-txn USD)
+ (xaccTransSetDate buy-txn 1 1 2020)
+ (xaccTransSetDescription buy-txn "Buy AAPL lot")
+
+ (xaccSplitSetAccount buy-stock aapl-acct)
+ (xaccSplitSetAmount buy-stock (gnc-numeric-create 100 1))
+ (xaccSplitSetValue buy-stock (gnc-numeric-create 5000 1))
+ (xaccSplitSetParent buy-stock buy-txn)
+ (gnc-lot-add-split lot buy-stock)
+
+ (xaccSplitSetAccount buy-cash cash)
+ (xaccSplitSetAmount buy-cash (gnc-numeric-create -5000 1))
+ (xaccSplitSetValue buy-cash (gnc-numeric-create -5000 1))
+ (xaccSplitSetParent buy-cash buy-txn)
+ (xaccTransCommitEdit buy-txn)
+
+ ;; Reverse split: remove 50 shares with zero proceeds.
+ (xaccTransBeginEdit split-txn)
+ (xaccTransSetCurrency split-txn USD)
+ (xaccTransSetDate split-txn 1 2 2020)
+ (xaccTransSetDescription split-txn "Reverse Split")
+
+ (xaccSplitSetAccount split-split aapl-acct)
+ (xaccSplitSetAmount split-split (gnc-numeric-create -50 1))
+ (xaccSplitSetValue split-split (gnc-numeric-create 0 1))
+ (xaccSplitMakeStockSplit split-split)
+ (xaccSplitSetAction split-split "Split")
+ (xaccSplitSetParent split-split split-txn)
+ (gnc-lot-add-split lot split-split)
+ (xaccTransCommitEdit split-txn)
+
+ account-alist)))
+
+(define (create-baseline-lot-test-data)
+ (let* ((book (gnc-get-current-book))
+ (env (create-test-env))
+ (USD (mnemonic->commodity "USD"))
+ (comm-table (gnc-commodity-table-get-table book))
+ (AAPL (gnc-commodity-new book "Apple" "NASDAQ" "AAPL" "" 1))
+ (structure
+ (list "Root" (list (cons 'type ACCT-TYPE-ASSET)
+ (cons 'commodity USD))
+ (list "Assets"
+ (list "Broker" (list (cons 'commodity USD))
+ (list "Cash" (list (cons 'commodity USD)))
+ (list "AAPL" (list (cons 'commodity AAPL)
+ (cons 'type ACCT-TYPE-STOCK))))))))
+
+ (gnc-commodity-table-insert comm-table AAPL)
+
+ (let* ((account-alist (env-create-account-structure-alist env structure))
+ (cash (cdr (assoc "Cash" account-alist)))
+ (aapl-acct (cdr (assoc "AAPL" account-alist)))
+ (lot (gnc-lot-new book))
+ (buy-txn (xaccMallocTransaction book))
+ (buy-stock (xaccMallocSplit book))
+ (buy-cash (xaccMallocSplit book)))
+
+ ;; Buy 100 shares into one explicit lot, with no split events.
+ (xaccTransBeginEdit buy-txn)
+ (xaccTransSetCurrency buy-txn USD)
+ (xaccTransSetDate buy-txn 1 1 2020)
+ (xaccTransSetDescription buy-txn "Buy AAPL lot baseline")
+
+ (xaccSplitSetAccount buy-stock aapl-acct)
+ (xaccSplitSetAmount buy-stock (gnc-numeric-create 100 1))
+ (xaccSplitSetValue buy-stock (gnc-numeric-create 5000 1))
+ (xaccSplitSetParent buy-stock buy-txn)
+ (gnc-lot-add-split lot buy-stock)
+
+ (xaccSplitSetAccount buy-cash cash)
+ (xaccSplitSetAmount buy-cash (gnc-numeric-create -5000 1))
+ (xaccSplitSetValue buy-cash (gnc-numeric-create -5000 1))
+ (xaccSplitSetParent buy-cash buy-txn)
+ (xaccTransCommitEdit buy-txn)
+
+ account-alist)))
+
+(define (create-reverse-split-with-sale-test-data)
+ (let* ((book (gnc-get-current-book))
+ (env (create-test-env))
+ (USD (mnemonic->commodity "USD"))
+ (comm-table (gnc-commodity-table-get-table book))
+ (AAPL (gnc-commodity-new book "Apple" "NASDAQ" "AAPL" "" 1))
+ (structure
+ (list "Root" (list (cons 'type ACCT-TYPE-ASSET)
+ (cons 'commodity USD))
+ (list "Assets"
+ (list "Broker" (list (cons 'commodity USD))
+ (list "Cash" (list (cons 'commodity USD)))
+ (list "AAPL" (list (cons 'commodity AAPL)
+ (cons 'type ACCT-TYPE-STOCK))))))))
+
+ (gnc-commodity-table-insert comm-table AAPL)
+
+ (let* ((account-alist (env-create-account-structure-alist env structure))
+ (cash (cdr (assoc "Cash" account-alist)))
+ (aapl-acct (cdr (assoc "AAPL" account-alist)))
+ (lot (gnc-lot-new book))
+ (buy-txn (xaccMallocTransaction book))
+ (buy-stock (xaccMallocSplit book))
+ (buy-cash (xaccMallocSplit book))
+ (split-txn (xaccMallocTransaction book))
+ (split-split (xaccMallocSplit book))
+ (sale-txn (xaccMallocTransaction book))
+ (sale-stock (xaccMallocSplit book))
+ (sale-cash (xaccMallocSplit book)))
+
+ ;; Buy 100 shares, $5,000 basis.
+ (xaccTransBeginEdit buy-txn)
+ (xaccTransSetCurrency buy-txn USD)
+ (xaccTransSetDate buy-txn 1 1 2020)
+ (xaccTransSetDescription buy-txn "Buy AAPL lot")
+ (xaccSplitSetAccount buy-stock aapl-acct)
+ (xaccSplitSetAmount buy-stock (gnc-numeric-create 100 1))
+ (xaccSplitSetValue buy-stock (gnc-numeric-create 5000 1))
+ (xaccSplitSetParent buy-stock buy-txn)
+ (gnc-lot-add-split lot buy-stock)
+ (xaccSplitSetAccount buy-cash cash)
+ (xaccSplitSetAmount buy-cash (gnc-numeric-create -5000 1))
+ (xaccSplitSetValue buy-cash (gnc-numeric-create -5000 1))
+ (xaccSplitSetParent buy-cash buy-txn)
+ (xaccTransCommitEdit buy-txn)
+
+ ;; Reverse split removes 50 shares, zero proceeds.
+ (xaccTransBeginEdit split-txn)
+ (xaccTransSetCurrency split-txn USD)
+ (xaccTransSetDate split-txn 1 2 2020)
+ (xaccTransSetDescription split-txn "Reverse Split")
+ (xaccSplitSetAccount split-split aapl-acct)
+ (xaccSplitSetAmount split-split (gnc-numeric-create -50 1))
+ (xaccSplitSetValue split-split (gnc-numeric-create 0 1))
+ (xaccSplitMakeStockSplit split-split)
+ (xaccSplitSetAction split-split "Split")
+ (xaccSplitSetParent split-split split-txn)
+ (gnc-lot-add-split lot split-split)
+ (xaccTransCommitEdit split-txn)
+
+ ;; Sell 25 shares for $3,000.
+ (xaccTransBeginEdit sale-txn)
+ (xaccTransSetCurrency sale-txn USD)
+ (xaccTransSetDate sale-txn 1 3 2020)
+ (xaccTransSetDescription sale-txn "Sell AAPL")
+ (xaccSplitSetAccount sale-stock aapl-acct)
+ (xaccSplitSetAmount sale-stock (gnc-numeric-create -25 1))
+ (xaccSplitSetValue sale-stock (gnc-numeric-create -3000 1))
+ (xaccSplitSetParent sale-stock sale-txn)
+ (gnc-lot-add-split lot sale-stock)
+ (xaccSplitSetAccount sale-cash cash)
+ (xaccSplitSetAmount sale-cash (gnc-numeric-create 3000 1))
+ (xaccSplitSetValue sale-cash (gnc-numeric-create 3000 1))
+ (xaccSplitSetParent sale-cash sale-txn)
+ (xaccTransCommitEdit sale-txn)
+
+ account-alist)))
+
+(define (create-equivalent-postsplit-sale-baseline-test-data)
+ (let* ((book (gnc-get-current-book))
+ (env (create-test-env))
+ (USD (mnemonic->commodity "USD"))
+ (comm-table (gnc-commodity-table-get-table book))
+ (AAPL (gnc-commodity-new book "Apple" "NASDAQ" "AAPL" "" 1))
+ (structure
+ (list "Root" (list (cons 'type ACCT-TYPE-ASSET)
+ (cons 'commodity USD))
+ (list "Assets"
+ (list "Broker" (list (cons 'commodity USD))
+ (list "Cash" (list (cons 'commodity USD)))
+ (list "AAPL" (list (cons 'commodity AAPL)
+ (cons 'type ACCT-TYPE-STOCK))))))))
+
+ (gnc-commodity-table-insert comm-table AAPL)
+
+ (let* ((account-alist (env-create-account-structure-alist env structure))
+ (cash (cdr (assoc "Cash" account-alist)))
+ (aapl-acct (cdr (assoc "AAPL" account-alist)))
+ (lot (gnc-lot-new book))
+ (buy-txn (xaccMallocTransaction book))
+ (buy-stock (xaccMallocSplit book))
+ (buy-cash (xaccMallocSplit book))
+ (sale-txn (xaccMallocTransaction book))
+ (sale-stock (xaccMallocSplit book))
+ (sale-cash (xaccMallocSplit book)))
+
+ ;; Equivalent post-split basis: buy 50 shares for $5,000.
+ (xaccTransBeginEdit buy-txn)
+ (xaccTransSetCurrency buy-txn USD)
+ (xaccTransSetDate buy-txn 1 1 2020)
+ (xaccTransSetDescription buy-txn "Buy AAPL baseline")
+ (xaccSplitSetAccount buy-stock aapl-acct)
+ (xaccSplitSetAmount buy-stock (gnc-numeric-create 50 1))
+ (xaccSplitSetValue buy-stock (gnc-numeric-create 5000 1))
+ (xaccSplitSetParent buy-stock buy-txn)
+ (gnc-lot-add-split lot buy-stock)
+ (xaccSplitSetAccount buy-cash cash)
+ (xaccSplitSetAmount buy-cash (gnc-numeric-create -5000 1))
+ (xaccSplitSetValue buy-cash (gnc-numeric-create -5000 1))
+ (xaccSplitSetParent buy-cash buy-txn)
+ (xaccTransCommitEdit buy-txn)
+
+ ;; Sell 25 shares for $3,000.
+ (xaccTransBeginEdit sale-txn)
+ (xaccTransSetCurrency sale-txn USD)
+ (xaccTransSetDate sale-txn 1 3 2020)
+ (xaccTransSetDescription sale-txn "Sell AAPL baseline")
+ (xaccSplitSetAccount sale-stock aapl-acct)
+ (xaccSplitSetAmount sale-stock (gnc-numeric-create -25 1))
+ (xaccSplitSetValue sale-stock (gnc-numeric-create -3000 1))
+ (xaccSplitSetParent sale-stock sale-txn)
+ (gnc-lot-add-split lot sale-stock)
+ (xaccSplitSetAccount sale-cash cash)
+ (xaccSplitSetAmount sale-cash (gnc-numeric-create 3000 1))
+ (xaccSplitSetValue sale-cash (gnc-numeric-create 3000 1))
+ (xaccSplitSetParent sale-cash sale-txn)
+ (xaccTransCommitEdit sale-txn)
+
+ account-alist)))
+
+(define (find-col-index labels target)
+ (let loop ((rest labels) (i 1))
+ (cond
+ ((null? rest) #f)
+ ((and (string? (car rest)) (string=? (car rest) target)) i)
+ (else (loop (cdr rest) (+ i 1))))))
+
+(define (list-any pred lst)
+ (if (null? lst)
+ #f
+ (or (pred (car lst))
+ (list-any pred (cdr lst)))))
+
+(define (test-investment-lots)
+ ;; Test rendering with various configurations
+ (test-group-with-cleanup "rendering-tests"
+ (let* ((account-alist (create-investment-lots-test-data)))
+
+ ;; Test 1: Basic rendering with defaults
+ (test-begin "basic-rendering")
+ (let ((options (gnc:make-report-options uuid)))
+ (test-assert "report-renders" (render-report options "default")))
+ (test-end "basic-rendering")
+
+ ;; Test 2: CAGR columns (new in PR #1956)
+ (test-begin "cagr-columns")
+ (let ((options (gnc:make-report-options uuid)))
+ (set-option! options "Columns" "Show CAGR columns" #t)
+ (test-assert "renders-with-cagr" (render-report options "with-cagr")))
+ (test-end "cagr-columns")
+
+ ;; Test 3: Gain columns visibility
+ (test-begin "gain-columns")
+ (let ((options (gnc:make-report-options uuid)))
+ (set-option! options "Columns" "Show realized gain columns" #t)
+ (set-option! options "Columns" "Show unrealized gain columns" #t)
+ (test-assert "renders-gains" (render-report options "with-gains")))
+ (test-end "gain-columns")
+
+ ;; Test 4: LT/ST grouping
+ (test-begin "lt-st-grouping")
+ (let ((options (gnc:make-report-options uuid)))
+ (set-option! options "Columns" "Group gains by age (short term and long term)" 'gains-only)
+ (test-assert "renders-lt-st" (render-report options "with-lt-st")))
+ (test-end "lt-st-grouping")
+
+ ;; Test 5: ROI columns
+ (test-begin "roi-columns")
+ (let ((options (gnc:make-report-options uuid)))
+ (set-option! options "Columns" "Show ROI columns" #t)
+ (test-assert "renders-roi" (render-report options "with-roi")))
+ (test-end "roi-columns")
+
+ ;; Test 6: All column types enabled
+ (test-begin "all-columns-enabled")
+ (let ((options (gnc:make-report-options uuid)))
+ (set-option! options "Columns" "Show bought columns" #t)
+ (set-option! options "Columns" "Show sold columns" #t)
+ (set-option! options "Columns" "Show end columns" #t)
+ (set-option! options "Columns" "Show realized gain columns" #t)
+ (set-option! options "Columns" "Show unrealized gain columns" #t)
+ (set-option! options "Columns" "Show ROI columns" #t)
+ (set-option! options "Columns" "Show CAGR columns" #t)
+ (test-assert "renders-all-columns" (render-report options "all-columns")))
+ (test-end "all-columns-enabled")
+
+ ;; Test 7: Chart display
+ (test-begin "chart-display")
+ (let ((options (gnc:make-report-options uuid)))
+ (set-option! options "Chart" "Show Chart" #t)
+ (test-assert "renders-with-chart" (render-report options "with-chart")))
+ (test-end "chart-display"))
+
+ ;; Cleanup
+ (gnc-clear-current-session))
+
+ ;; Test options integrity
+ (test-group-with-cleanup "options-integrity"
+ (let ((options (gnc:make-report-options uuid)))
+ (test-begin "all-options-exist")
+
+ ;; Verify each option can be set
+ (test-assert "show-purchased"
+ (set-option! options "Columns" "Show bought columns" #t))
+ (test-assert "show-sold"
+ (set-option! options "Columns" "Show sold columns" #t))
+ (test-assert "show-end"
+ (set-option! options "Columns" "Show end columns" #t))
+ (test-assert "show-realized-gains"
+ (set-option! options "Columns" "Show realized gain columns" #t))
+ (test-assert "show-unrealized-gains"
+ (set-option! options "Columns" "Show unrealized gain columns" #t))
+ (test-assert "show-roi"
+ (set-option! options "Columns" "Show ROI columns" #t))
+ (test-assert "show-cagr"
+ (set-option! options "Columns" "Show CAGR columns" #t))
+ (test-assert "group-gains"
+ (set-option! options "Columns" "Group gains by age (short term and long term)" 'gains-and-sales))
+ (test-assert "show-chart"
+ (set-option! options "Chart" "Show Chart" #t))
+ (test-assert "show-validation"
+ (set-option! options "Validation" "Include only accounts with warnings" #t))
+
+ (test-end "all-options-exist"))
+ (gnc-clear-current-session))
+
+ ;; Test different configurations
+ (test-group-with-cleanup "configuration-variants"
+ (let* ((account-alist (create-investment-lots-test-data)))
+
+ (test-begin "column-combinations")
+ (let ((options (gnc:make-report-options uuid)))
+ ;; Test combinations of columns
+ (set-option! options "Columns" "Show realized gain columns" #t)
+ (set-option! options "Columns" "Show ROI columns" #t)
+ (test-assert "realized-gains-and-roi" (render-report options "realized-roi")))
+ (test-end "column-combinations")
+
+ (test-begin "grouping-variants")
+ (let ((opt1 (gnc:make-report-options uuid))
+ (opt2 (gnc:make-report-options uuid))
+ (opt3 (gnc:make-report-options uuid)))
+ ;; Test different grouping options
+ (set-option! opt1 "Columns" "Group gains by age (short term and long term)" 'no)
+ (set-option! opt2 "Columns" "Group gains by age (short term and long term)" 'gains-only)
+ (set-option! opt3 "Columns" "Group gains by age (short term and long term)" 'gains-and-sales)
+ (test-assert "no-grouping" (render-report opt1 "no-grouping"))
+ (test-assert "gains-grouping" (render-report opt2 "gains-grouping"))
+ (test-assert "gains-sales-grouping" (render-report opt3 "gains-sales-grouping")))
+ (test-end "grouping-variants"))
+
+ (gnc-clear-current-session))
+
+ ;; Test calculation functions (new module-level pure functions)
+ (test-group-with-cleanup "calculation-functions"
+ (test-begin "cagr-calculations")
+ ;; Test CAGR calculation with known values
+ ;; $100 → $200 in 1 year = 100% CAGR = 1.0
+ (let* ((basis (gnc-numeric-create 100 1))
+ (end-value (gnc-numeric-create 200 1))
+ (years 1)
+ (result (calculate-cagr basis end-value years)))
+ (test-assert "doubling-in-year" (and result (>= result 0.99) (<= result 1.01))))
+
+ ;; $100 → $100 in 1 year = 0% CAGR = 0.0
+ (let* ((basis (gnc-numeric-create 100 1))
+ (end-value (gnc-numeric-create 100 1))
+ (years 1)
+ (result (calculate-cagr basis end-value years)))
+ (test-assert "zero-growth" (and result (>= result -0.01) (<= result 0.01))))
+
+ ;; Invalid: zero basis
+ (let ((result (calculate-cagr (gnc-numeric-create 0 1)
+ (gnc-numeric-create 100 1) 1)))
+ (test-assert "zero-basis-undefined" (eq? result #f)))
+
+ ;; Invalid: false basis
+ (let ((result (calculate-cagr #f (gnc-numeric-create 100 1) 1)))
+ (test-assert "false-basis-undefined" (eq? result #f)))
+
+ ;; Invalid: negative basis should not produce complex numbers
+ (let ((result (calculate-cagr (gnc-numeric-create -100 1)
+ (gnc-numeric-create 100 1)
+ 1)))
+ (test-assert "negative-basis-undefined" (eq? result #f)))
+
+ ;; Invalid: negative end value should not produce complex numbers
+ (let ((result (calculate-cagr (gnc-numeric-create 100 1)
+ (gnc-numeric-create -50 1)
+ 1)))
+ (test-assert "negative-end-value-undefined" (eq? result #f)))
+
+ ;; $1000 → $1100 in 1 year = 10% CAGR
+ (let* ((basis (gnc-numeric-create 1000 1))
+ (end-value (gnc-numeric-create 1100 1))
+ (years 1)
+ (result (calculate-cagr basis end-value years)))
+ (test-assert "ten-percent-gain" (and result (>= result 0.09) (<= result 0.11))))
+
+ ;; $100 → $110 in 2 years ≈ 4.88% CAGR
+ (let* ((basis (gnc-numeric-create 100 1))
+ (end-value (gnc-numeric-create 110 1))
+ (years 2)
+ (result (calculate-cagr basis end-value years)))
+ (test-assert "110-in-2years" (and result (>= result 0.04) (<= result 0.06))))
+
+ (test-end "cagr-calculations")
+
+ (test-begin "gain-calculations")
+ ;; $100 basis, $150 end value = $50 gain
+ (let* ((basis (gnc-numeric-create 100 1))
+ (end-value (gnc-numeric-create 150 1))
+ (gain (calculate-gain basis end-value)))
+ (test-assert "positive-gain" (not (gnc-numeric-negative-p gain)))
+ (test-assert "fifty-dollar-gain"
+ (gnc-numeric-zero-p
+ (gnc-numeric-sub-fixed gain (gnc-numeric-create 50 1)))))
+
+ ;; $100 basis, $80 end value = -$20 loss
+ (let* ((basis (gnc-numeric-create 100 1))
+ (end-value (gnc-numeric-create 80 1))
+ (loss (calculate-gain basis end-value)))
+ (test-assert "negative-loss" (gnc-numeric-negative-p loss))
+ (test-assert "twenty-dollar-loss"
+ (gnc-numeric-zero-p
+ (gnc-numeric-sub-fixed loss (gnc-numeric-create -20 1)))))
+
+ ;; No change: same value
+ (let* ((basis (gnc-numeric-create 100 1))
+ (end-value (gnc-numeric-create 100 1))
+ (gain (calculate-gain basis end-value)))
+ (test-assert "zero-change" (gnc-numeric-zero-p gain)))
+
+ (test-end "gain-calculations")
+
+ (test-begin "roi-calculations")
+ ;; $100 basis, $25 gain = 25% ROI
+ (let* ((basis (gnc-numeric-create 100 1))
+ (gain (gnc-numeric-create 25 1))
+ (result (calculate-roi basis gain)))
+ (test-assert "positive-roi" (and result (>= result 0.24) (<= result 0.26))))
+
+ ;; $100 basis, -$10 loss = -10% ROI
+ (let* ((basis (gnc-numeric-create 100 1))
+ (loss (gnc-numeric-create -10 1))
+ (result (calculate-roi basis loss)))
+ (test-assert "negative-roi" (and result (<= result -0.09) (>= result -0.11))))
+
+ ;; Invalid: zero basis
+ (let ((result (calculate-roi (gnc-numeric-create 0 1)
+ (gnc-numeric-create 25 1))))
+ (test-assert "zero-basis-roi-undefined" (eq? result #f)))
+
+ ;; $500 basis, $500 gain = 100% ROI
+ (let* ((basis (gnc-numeric-create 500 1))
+ (gain (gnc-numeric-create 500 1))
+ (result (calculate-roi basis gain)))
+ (test-assert "hundred-percent-roi" (and result (>= result 0.99) (<= result 1.01))))
+
+ ;; $200 basis, -$50 loss = -25% ROI
+ (let* ((basis (gnc-numeric-create 200 1))
+ (loss (gnc-numeric-create -50 1))
+ (result (calculate-roi basis loss)))
+ (test-assert "twentyfive-percent-loss" (and result (<= result -0.24) (>= result -0.26))))
+
+ (test-end "roi-calculations")
+
+ (test-begin "long-term-classification")
+ ;; 1 year holding = long-term (exactly at boundary)
+ (let* ((buy-date (gnc-dmy2time64 01 01 2020))
+ (sell-date (gnc-dmy2time64 01 01 2021))
+ (result (is-long-term? buy-date sell-date 1)))
+ (test-assert "one-year-is-lt" result))
+
+ ;; 364 days < 1 year = not long-term (just under)
+ (let* ((buy-date (gnc-dmy2time64 01 01 2020))
+ (sell-date (gnc-dmy2time64 31 12 2020))
+ (result (is-long-term? buy-date sell-date 1)))
+ (test-assert "364-days-not-lt" (not result)))
+
+ ;; 2 year holding with 1-year threshold = long-term
+ (let* ((buy-date (gnc-dmy2time64 01 01 2020))
+ (sell-date (gnc-dmy2time64 01 01 2022))
+ (result (is-long-term? buy-date sell-date 1)))
+ (test-assert "two-years-is-lt" result))
+
+ ;; 5 years holding = long-term
+ (let* ((buy-date (gnc-dmy2time64 01 01 2015))
+ (sell-date (gnc-dmy2time64 01 01 2020))
+ (result (is-long-term? buy-date sell-date 1)))
+ (test-assert "five-years-is-lt" result))
+
+ ;; Same day = not long-term (0 years)
+ (let* ((date (gnc-dmy2time64 01 01 2020))
+ (result (is-long-term? date date 1)))
+ (test-assert "same-day-not-lt" (not result)))
+
+ (test-end "long-term-classification")
+
+ (test-begin "reverse-split-classification")
+ (let ((stock-split-event?
+ (@@ (gnucash reports standard investment-lots)
+ stock-split-event?))
+ (is-non-realizing-share-reduction?
+ (@@ (gnucash reports standard investment-lots)
+ non-realizing-share-reduction?)))
+ ;; Integration check: real engine stock-split metadata must be detected.
+ (let* ((book (gnc-get-current-book))
+ (split (xaccMallocSplit book))
+ (amount (gnc-numeric-create -10 1))
+ (value (gnc-numeric-create 0 1)))
+ (xaccSplitSetAmount split amount)
+ (xaccSplitSetValue split value)
+ (xaccSplitMakeStockSplit split)
+ (xaccSplitSetAction split "Split")
+ (test-assert "engine-stock-split-type-detected"
+ (stock-split-event?
+ (xaccSplitGetType split)
+ (xaccSplitGetAction split)))
+ (test-assert "engine-reverse-split-classified"
+ (is-non-realizing-share-reduction?
+ (xaccSplitGetType split)
+ (xaccSplitGetAction split)
+ amount
+ value)))
+
+ ;; Reverse split style reduction should be treated as non-realizing.
+ (test-assert "stock-split-negative-zero-value"
+ (is-non-realizing-share-reduction?
+ "stock-split"
+ "Split"
+ (gnc-numeric-create -10 1)
+ (gnc-numeric-create 0 1)))
+
+ ;; Ordinary sale with zero proceeds is not auto-classified as split.
+ (test-assert "plain-sale-zero-value-not-split"
+ (not (is-non-realizing-share-reduction?
+ ""
+ ""
+ (gnc-numeric-create -10 1)
+ (gnc-numeric-create 0 1))))
+
+ ;; Forward split increases shares and is not a reduction event.
+ (test-assert "forward-split-not-reduction"
+ (not (is-non-realizing-share-reduction?
+ "stock-split"
+ "Split"
+ (gnc-numeric-create 10 1)
+ (gnc-numeric-create 0 1))))
+
+ ;; Matrix-style coverage on reduction detection gates used by split
+ ;; classification.
+ (test-assert "matrix-positive-amount-not-reduction"
+ (not (is-non-realizing-share-reduction?
+ ""
+ ""
+ (gnc-numeric-create 10 1)
+ (gnc-numeric-create 100 1))))
+ (test-assert "matrix-sale-with-proceeds-not-reduction"
+ (not (is-non-realizing-share-reduction?
+ ""
+ ""
+ (gnc-numeric-create -10 1)
+ (gnc-numeric-create -100 1))))
+ (test-assert "matrix-zero-amount-not-reduction"
+ (not (is-non-realizing-share-reduction?
+ ""
+ ""
+ (gnc-numeric-create 0 1)
+ (gnc-numeric-create 100 1))))
+ (test-assert "matrix-reduction-detected"
+ (is-non-realizing-share-reduction?
+ "stock-split"
+ "Split"
+ (gnc-numeric-create -10 1)
+ (gnc-numeric-create 0 1))))
+
+ (test-end "reverse-split-classification")
+
+ (gnc-clear-current-session))
+
+ ;; End-to-end rendered output regression for reverse split behavior.
+ (test-group-with-cleanup "reverse-split-render-regression"
+ (let* ((account-alist (create-reverse-split-lot-test-data))
+ (options (gnc:make-report-options uuid))
+ (sxml (options->sxml options "reverse-split-regression"))
+ (headers (sxml->table-row-col sxml 1 0 #f))
+ (sold-col (find-col-index headers "Sold Splits"))
+ (realized-col (find-col-index headers "Realized Gain")))
+
+ (test-assert "found-sold-splits-column" sold-col)
+ (test-assert "realized-gain-column-optional-when-no-sales" #t)
+
+ (let ((sold-values (sxml->table-row-col sxml 1 #f sold-col))
+ (realized-values (if realized-col
+ (sxml->table-row-col sxml 1 #f realized-col)
+ '())))
+ ;; Reverse split must not be counted as a sold split.
+ (test-assert "no-sold-split-count-one"
+ (not (list-any (lambda (v) (and (string? v) (string=? v "1")))
+ sold-values)))
+
+ ;; Reverse split must not produce phantom realized loss formatting.
+ (test-assert "no-phantom-negative-realized-loss"
+ (not (list-any (lambda (v)
+ (and (string? v)
+ (string-contains v "(")))
+ realized-values)))))
+
+ (gnc-clear-current-session))
+
+ ;; Compare baseline vs reverse-split render to ensure no phantom sale/gain.
+ (test-group-with-cleanup "reverse-split-vs-baseline-regression"
+ (let* ((base-alist (create-baseline-lot-test-data))
+ (base-options (gnc:make-report-options uuid))
+ (base-sxml (options->sxml base-options "baseline-lot"))
+ (base-headers (sxml->table-row-col base-sxml 1 0 #f))
+ (base-sold-col (find-col-index base-headers "Sold Splits"))
+ (base-realized-col (find-col-index base-headers "Realized Gain"))
+ (base-sold-values (if base-sold-col
+ (sxml->table-row-col base-sxml 1 #f base-sold-col)
+ '()))
+ (base-realized-values (if base-realized-col
+ (sxml->table-row-col base-sxml 1 #f base-realized-col)
+ '())))
+
+ (gnc-clear-current-session)
+
+ (let* ((rev-alist (create-reverse-split-lot-test-data))
+ (rev-options (gnc:make-report-options uuid))
+ (rev-sxml (options->sxml rev-options "reverse-split-vs-baseline"))
+ (rev-headers (sxml->table-row-col rev-sxml 1 0 #f))
+ (rev-sold-col (find-col-index rev-headers "Sold Splits"))
+ (rev-realized-col (find-col-index rev-headers "Realized Gain"))
+ (rev-sold-values (if rev-sold-col
+ (sxml->table-row-col rev-sxml 1 #f rev-sold-col)
+ '()))
+ (rev-realized-values (if rev-realized-col
+ (sxml->table-row-col rev-sxml 1 #f rev-realized-col)
+ '())))
+
+ (test-assert "sold-splits-equal-baseline-vs-reverse"
+ (equal? base-sold-values rev-sold-values))
+ (test-assert "realized-gain-equal-baseline-vs-reverse"
+ (equal? base-realized-values rev-realized-values))))
+
+ (gnc-clear-current-session))
+
+ ;; Reverse-split-with-sale should match equivalent post-split baseline.
+ (test-group-with-cleanup "reverse-split-with-sale-equivalence"
+ (let* ((base-alist (create-equivalent-postsplit-sale-baseline-test-data))
+ (base-options (gnc:make-report-options uuid))
+ (base-sxml (options->sxml base-options "equivalent-baseline-sale"))
+ (base-headers (sxml->table-row-col base-sxml 1 0 #f))
+ (base-sold-col (find-col-index base-headers "Sold Splits"))
+ (base-realized-col (find-col-index base-headers "Realized Gain"))
+ (base-sold-values (if base-sold-col
+ (sxml->table-row-col base-sxml 1 #f base-sold-col)
+ '()))
+ (base-realized-values (if base-realized-col
+ (sxml->table-row-col base-sxml 1 #f base-realized-col)
+ '())))
+
+ (gnc-clear-current-session)
+
+ (let* ((rev-alist (create-reverse-split-with-sale-test-data))
+ (rev-options (gnc:make-report-options uuid))
+ (rev-sxml (options->sxml rev-options "reverse-split-with-sale"))
+ (rev-headers (sxml->table-row-col rev-sxml 1 0 #f))
+ (rev-sold-col (find-col-index rev-headers "Sold Splits"))
+ (rev-realized-col (find-col-index rev-headers "Realized Gain"))
+ (rev-sold-values (if rev-sold-col
+ (sxml->table-row-col rev-sxml 1 #f rev-sold-col)
+ '()))
+ (rev-realized-values (if rev-realized-col
+ (sxml->table-row-col rev-sxml 1 #f rev-realized-col)
+ '())))
+
+ (test-assert "reverse-split-sale-has-sold-splits-column" rev-sold-col)
+ (test-assert "reverse-split-sale-realized-gain-column-optional" #t)
+ (test-assert "sold-splits-equal-equivalent-baseline"
+ (equal? base-sold-values rev-sold-values))
+ (test-assert "realized-gain-equal-equivalent-baseline"
+ (equal? base-realized-values rev-realized-values))))
+
+ (gnc-clear-current-session)))
Summary of changes:
.../report/reports/standard/investment-lots.scm | 814 +++++++++++++-------
.../report/reports/standard/test/CMakeLists.txt | 1 +
.../reports/standard/test/test-investment-lots.scm | 836 +++++++++++++++++++++
3 files changed, 1395 insertions(+), 256 deletions(-)
create mode 100644 gnucash/report/reports/standard/test/test-investment-lots.scm
More information about the gnucash-changes
mailing list