Advanced portfolio report [another version]

Morrison J. Chang mjchang at ix.netcom.com
Wed Nov 28 23:56:51 EST 2007


On Wed, 2007-11-28 at 23:38 -0500, Morrison J. Chang wrote:
> On Wed, 2007-11-28 at 22:46 -0500, Morrison J. Chang wrote:
> > 
> > I'll post what I've got shortly.
> 
> Okay here is the full file. This one also needs to be cleaned up for the
> log statements and comments.
> 
> I called it advanced-portfolio-test.scm so that I could run it with the
> old one.
> 
> If anything else this might be instructive to anyone looking to play
> around with scheme.
> 
> Notes:
> In this version I created two new lists for holding the sold-value and
> sold-basis-value. I apply stock splits against the basis in
> basis-modify.
> 
> Comments appreciated.
> 
> -Morrison
> 

Sorry about the repost.
Now as part of the message so that it is readable in the archives.

-Morrison

---- cut here ----
;; -*-scheme-*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; advanced-portfolio.scm
;; by Martijn van Oosterhout (kleptog at svana.org) Feb 2002
;; modified for GnuCash 1.8 by Herbert Thoma (herbie at hthoma.de) Oct 2002
;;
;; Heavily based on portfolio.scm
;; by Robert Merkel (rgmerk at mira.net)
;;
;; 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 at gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-module (gnucash report advanced-portfolio-test))

(use-modules (gnucash main)) ;; FIXME: delete after we finish
modularizing.
(use-modules (srfi srfi-1))
(use-modules (ice-9 slib))
(use-modules (gnucash gnc-module))

(require 'printf)

(gnc:module-load "gnucash/report/report-system" 0)

(define reportname (N_ "Advanced Portfolio TEST"))

(define optname-price-source (N_ "Price Source"))
(define optname-shares-digits (N_ "Share decimal places"))
(define optname-zero-shares (N_ "Include accounts with no shares"))
(define optname-include-gains (N_ "Include gains and losses"))
(define optname-show-symbol (N_ "Show ticker symbols"))
(define optname-show-listing (N_ "Show listings"))
(define optname-show-price (N_ "Show prices"))
(define optname-show-shares (N_ "Show number of shares"))
(define optname-basis-method (N_ "Basis calculation method"))
(define optname-prefer-pricelist (N_ "Set preference for price list
data"))

(define (options-generator)
  (let* ((options (gnc:new-options)) 
         ;; This is just a helper function for making options.
         ;; See gnucash/src/scm/options.scm for details.
         (add-option 
          (lambda (new-option)
            (gnc:register-option options new-option))))

    ;; General Tab
    ;; date at which to report balance
    (gnc:options-add-report-date!
     options gnc:pagename-general 
     (N_ "Date") "a")

    (gnc:options-add-currency! 
     options gnc:pagename-general (N_ "Report Currency") "c")

    (add-option
     (gnc:make-multichoice-option
      gnc:pagename-general optname-price-source
      "d" (N_ "The source of price information") 'pricedb-nearest
      (list (vector 'pricedb-latest 
		    (N_ "Most recent")
		    (N_ "The most recent recorded price"))
	    (vector 'pricedb-nearest
		    (N_ "Nearest in time")
		    (N_ "The price recorded nearest in time to the report date"))
	    (vector 'pricedb-latest-before
		    (N_ "Most recent to report")
		    (N_ "The most recent recorded price before report date"))
	    )))
    
    (add-option
     (gnc:make-multichoice-option
      gnc:pagename-general optname-basis-method
      "e" (N_ "Basis calculation method") 'average-basis
      (list (vector 'average-basis
		    (N_ "Average")
		    (N_ "Use average cost of all shares for basis"))
	    (vector 'fifo-basis
		    (N_ "FIFO")
		    (N_ "Use first-in first-out method for basis"))
	    (vector 'filo-basis
		    (N_ "FILO")
		    (N_ "Use first-in last-out method for basis"))
	    )))

    (add-option
     (gnc:make-simple-boolean-option
      gnc:pagename-general optname-prefer-pricelist "f" 
      (N_ "Prefer use of price editor pricing over transactions, where
applicable.")
      #t))


    (gnc:register-option 
     options 
     (gnc:make-simple-boolean-option
      gnc:pagename-general optname-include-gains "g" 
      (N_ "Include splits with no shares for calculating money-in and
money-out")
      #f))

    (gnc:register-option
      options
      (gnc:make-simple-boolean-option
	gnc:pagename-display optname-show-symbol "a"
	(N_ "Display the ticker symbols")
	#t))

    (gnc:register-option
      options
      (gnc:make-simple-boolean-option
	gnc:pagename-display optname-show-listing "b"
	(N_ "Display exchange listings")
	#t))

    (gnc:register-option
      options
      (gnc:make-simple-boolean-option
	gnc:pagename-display optname-show-shares "c"
	(N_ "Display numbers of shares in accounts")
	#t))

    (add-option
     (gnc:make-number-range-option
      gnc:pagename-display optname-shares-digits
      "d" (N_ "The number of decimal places to use for share numbers") 2
      0 6 0 1))

    (gnc:register-option
      options
      (gnc:make-simple-boolean-option
	gnc:pagename-display optname-show-price "e"
	(N_ "Display share prices")
	#t))

    ;; Account tab
    (add-option
     (gnc:make-account-list-option
      gnc:pagename-accounts (N_ "Accounts")
      "b"
      (N_ "Stock Accounts to report on")
      (lambda () (filter gnc:account-is-stock?
                         (gnc-account-get-descendants-sorted
                          (gnc-get-current-root-account))))
      (lambda (accounts) (list  #t 
                                (filter gnc:account-is-stock?
accounts)))
      #t))

    (gnc:register-option 
     options 
     (gnc:make-simple-boolean-option
      gnc:pagename-accounts optname-zero-shares "e" 
      (N_ "Include accounts that have a zero share balances.")
      #f))
    
    (gnc:options-set-default-section options gnc:pagename-general)      
    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 (advanced-portfolio-renderer report-obj)
  
 (let ((work-done 0)
       (work-to-do 0)
       (warn-price-dirty #f))

  ;; These are some helper functions for looking up option values.
  (define (get-op section name)
    (gnc:lookup-option (gnc:report-options report-obj) section name))
  
  (define (get-option section name)
    (gnc:option-value (get-op section name)))
  
  (define (split-account-type? split type)
    (eq? type (xaccAccountGetType (xaccSplitGetAccount split))))

  (define (same-split? s1 s2)
    (string=? (gncSplitGetGUID s1) (gncSplitGetGUID s2)))

  (define (same-account? a1 a2)
    (string=? (gncAccountGetGUID a1) (gncAccountGetGUID a2)))
  
  ;; this builds a list for basis calculation and handles average, fifo
and filo methods
  ;; the list is cons cells of (units-of-stock . price-per-unit)...
average method produces only one
  ;; cell that mutates to the new average. Need to add a date checker so
that we allow for prices
  ;; coming in out of order, such as a transfer with a price adjusted to
carryover the basis.
  (define (basis-builder b-list b-units b-value b-method)
    (gnc:msg "in basis-builder:" b-list ":::" b-units ":::" b-value
":::" b-method)
    ;; (if (not (gnc-numeric-zero-p b-units))
	(if (gnc-numeric-positive-p b-units)
	(case b-method
	  ((average-basis) 
           (cond ((not (eqv? b-list '()))
		 (list (cons (gnc-numeric-add b-units
					      (caar b-list) GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE
GNC-RND-NEVER)) 
			     (gnc-numeric-div
			      (gnc-numeric-add b-value
					       (gnc-numeric-mul (caar b-list)
								(cdar b-list) 
								GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))
					       GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))
			      (gnc-numeric-add b-units
					       (caar b-list) GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE
GNC-RND-NEVER))
			      GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))))
;;		 (gnc:msg " test math " b-units ":::" (caar b-list)  )
		 )
		 (else (list (cons b-units (gnc-numeric-div
				      b-value b-units
				      GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER)))))))

	  (else (append b-list 
                        (list (cons b-units (gnc-numeric-div
                                             b-value b-units
					     GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER)))))))
	(if (not (eqv? b-list '()))
	    (case b-method
	      ((fifo-basis) 
               (if (not (= -1 (gnc-numeric-compare
                               (gnc-numeric-abs b-units) (caar
b-list))))
                   (basis-builder (cdr b-list) (gnc-numeric-add
                                                b-units 
                                                (caar b-list)
GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER)) 
                                  b-value b-method)
                   (append (list (cons (gnc-numeric-add
                                        b-units 
                                        (caar b-list) GNC-DENOM-AUTO
(logior GNC-DENOM-REDUCE GNC-RND-NEVER)) 
                                       (cdar b-list))) (cdr b-list))))
	      ((filo-basis) 
               (if (not (= -1 (gnc-numeric-compare
                               (gnc-numeric-abs b-units) (caar (reverse
b-list)))))
                   (basis-builder (reverse (cdr (reverse b-list))) 
                                  (gnc-numeric-add
                                   b-units 
                                   (caar (reverse b-list)) 
                                   GNC-DENOM-AUTO (logior
GNC-DENOM-REDUCE GNC-RND-NEVER)) 
                                  b-value b-method)
                   (append (cdr (reverse b-list)) 
                           (list (cons (gnc-numeric-add
                                        b-units 
                                        (caar (reverse b-list))
GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER)) 
                                       (cdar (reverse b-list)))))))
	      ((average-basis) 
               (list (cons (gnc-numeric-add
                            (caar b-list) b-units GNC-DENOM-AUTO (logior
GNC-DENOM-REDUCE GNC-RND-NEVER)) 
                           (cdar b-list))))
	      )
	    '()
	    )
	)
    )

  ;; sum up the contents of the b-list built by basis-builder above
  (define (sum-basis b-list)
    (if (not (eqv? b-list '()))
;;	   (gnc:msg "in sum-basis " b-list)
	   (gnc-numeric-add (gnc-numeric-mul (caar b-list) (cdar b-list) 100
GNC-RND-ROUND)
			    (sum-basis (cdr b-list)) 100 GNC-RND-ROUND)
	(gnc-numeric-zero)
	)
    )
  
  ;; sum up the total number of units in the b-list built by
basis-builder above
  (define (sum-units b-list)
    (if (not (eqv? b-list '()))
	(gnc-numeric-add (caar b-list) (sum-units (cdr b-list)) 100
GNC-RND-ROUND)
	(gnc-numeric-zero)
	)
    )


  ;; return the basis-value of units sold
  ;; b-list is the basis-list in left to right time order
  ;; units-amt is the negative number of units sold
  (define (get-basis-value b-list units-amt)
    (gnc:msg "in get-basis-value " b-list "::" units-amt)
    (if (not (eqv? b-list '()))
	(if (<= (gnc-numeric-compare (gnc-numeric-abs units-amt)
				       (caar b-list))
		0)
	    ;; units-amt is smaller than or equal to purchase, return purchase
basis
	    (gnc-numeric-mul (gnc-numeric-abs units-amt)
			     (cdar b-list)
			     GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))
	    ;; units-amt is larger than purchase so add units * price to
remaining b-list
	    (gnc-numeric-add (gnc-numeric-mul (caar b-list)
					       (cdar b-list)
					       GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))
			     (get-basis-value (cdr b-list)
					      (gnc-numeric-add units-amt
							       (gnc-numeric-mul (caar b-list)
										 (cdar b-list)
										 GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))
							       GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER)))
			     GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))
	    )
	;; empty b-list so return zero since you can't sell more than you have
	(gnc-numeric-zero)
	)
    )
 

 ;; modify the basis-list to handle equity stock split scenario
 ;; change in shares to be applied to b-list per b-method
 ;; in the case of average basis just add to units and apply factor to
price
 ;; in the case of fifo and filo
 ;; apply a factor to the contents of b-list (needed for handling equity
stock splits/reverse splits)
 ;; factor should be (original sum of units + additional split units) /
original sum of units
 ;; so a 2 for 1 split of 100 shares would be (100+100)/(100) = 2
 ;; conversely a 1 for 4 reverse split of 100 shares would be (100 -
75)/(100) = 0.25
 ;; the factor has to be applied to both parts of the cell
(units-of-stock . price-per-unit) to maintain value
 ;; new-units-of-stock = units-of-stock * factor
 ;; new-price-per-unit = price-per-unit / factor
 (define (basis-modify b-list b-units b-method)
   (if (not (eqv? b-list '()))
       (case b-method
	 ((average-basis)
	  (list (cons
		 (gnc-numeric-add b-units
				  (caar b-list) GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE
GNC-RND-NEVER))
		 (gnc-numeric-div (cdar b-list) 
				  (gnc-numeric-div (gnc-numeric-add b-units
								    (caar b-list) GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE
GNC-RND-NEVER))
						   (caar b-list) GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE
GNC-RND-NEVER))
				  GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))))
	  )
	 ((fifo-basis filo-basis)
	  (let ((factor (gnc-numeric-div (gnc-numeric-add (sum-units b-list)
							  b-units
							  GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))
					 (sum-units b-list)
					 GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))))
	  (map (lambda (cell) 
		 (cons (gnc-numeric-mul (car cell)
					factor
					GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))
		       (gnc-numeric-div (cdr cell)
					factor
					GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER))))
	       b-list))
	   )
	 )
       '()
       ))
								
  
(define (table-add-stock-rows table accounts to-date
                                currency price-fn exchange-fn 
				include-empty include-gains show-symbol show-listing show-shares
show-price
                                basis-method prefer-pricelist
total-basis total-value total-moneyin total-moneyout
                                total-gain total-ugain)

   (let ((share-print-info
	  (gnc-share-print-info-places
	   (inexact->exact (get-option gnc:pagename-display
      			       optname-shares-digits)))))
    
    (define (table-add-stock-rows-internal accounts odd-row?)
      (if (null? accounts) total-value
          (let* ((row-style (if odd-row? "normal-row" "alternate-row"))
                 (current (car accounts))
                 (rest (cdr accounts))
                 (name (xaccAccountGetName current))
                 (commodity (xaccAccountGetCommodity current))
                 (ticker-symbol (gnc-commodity-get-mnemonic commodity))
                 (listing (gnc-commodity-get-namespace commodity))
                 (unit-collector (gnc:account-get-comm-balance-at-date
                                  current to-date #f))
                 (units (cadr (unit-collector 'getpair commodity #f)))
;;                 (totalunits 0.0) ;;      these two items do nothing,
but are in a debug below, 
 ;;                (totalunityears 0.0);;   so I'm leaving it. asw

                 ;; Counter to keep track of stuff
                 (unitscoll     (gnc:make-commodity-collector))
                 (brokeragecoll (gnc:make-commodity-collector))
                 (dividendcoll  (gnc:make-commodity-collector))
                 (moneyincoll   (gnc:make-commodity-collector))
                 (moneyoutcoll  (gnc:make-commodity-collector))
                 (gaincoll      (gnc:make-commodity-collector))
		 (soldbasiscoll (gnc:make-commodity-collector))
		 (soldvaluecoll (gnc:make-commodity-collector))

                 (price-list (price-fn commodity to-date))
                 (price      (if (> (length price-list) 0)
				 (car price-list) #f))
		 ;; if there is no price, set a sane commod-currency for those
zero-share 
		 ;; accounts. if its a no price account with shares, we'll get a
currency later.
		 (commod-currency (if price (gnc-price-get-currency price) currency))
                 (value (exchange-fn (gnc:make-gnc-monetary commodity
units) currency))

		 (txn-value (gnc-numeric-zero))
		 (txn-date to-date)
		 (pricing-txn #f)
		 (use-txn #f)
		 (basis-list '())
		 (txn-units (gnc-numeric-zero))
		 (sold-basis-value-list '())
		 (sold-value-list '())
		 )


            (gnc:msg "---" name "---")
	    (for-each
	     (lambda (split)
	       (set! work-done (+ 1 work-done))
	       (gnc:msg "work-done " work-done)
	       (gnc:report-percent-done (* 100 (/ work-done work-to-do)))
	       (let ((parent (xaccSplitGetParent split)))
		 (if (gnc:timepair-le (gnc-transaction-get-date-posted parent)
to-date)
		     (begin
		       (set! txn-value (gnc-numeric-zero))
		       (set! txn-units (gnc-numeric-zero))
		       ;; Iterate through split transaction
		       ;; Appropriately set txn-value and txn-units for basis
calculation
		       (for-each
			(lambda (s)
			  ;; only for non zero amount (shares) set txn-value and txn-units
			  (cond
			   ((and (same-account? current (xaccSplitGetAccount s))
				 (not (gnc-numeric-zero-p (xaccSplitGetAmount s))))
			    (if (not price)
				(set! commod-currency (xaccAccountGetCommodity (xaccSplitGetAccount
s)))
				)
			    ;; add up the non-zero values in both txn-value and txn-amount
for this asset account in this ledger-split
			    (set! txn-value (gnc-numeric-add (xaccSplitGetValue s) txn-value
GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER)))
			    (set! txn-units (gnc-numeric-add (xaccSplitGetAmount s) txn-units
GNC-DENOM-AUTO (logior GNC-DENOM-REDUCE GNC-RND-NEVER)))
			    (set! txn-date (gnc-transaction-get-date-posted parent))
			    (set! pricing-txn parent)
			    (gnc:msg "Ledger split " txn-value "///" txn-units)
			    )
			   )
			  )
			(xaccTransGetSplitList parent))

		       ;; go build the basis-list
		       ;; the use of exchange-fn here is an attempt to get the basis
list into one
		       ;; currency to help accomodate stock transfers and other
things. might not work.
 		       (gnc:msg "create basis-list" basis-list "::" txn-units "::"
txn-value)

		       ;; if this is a sale (both txn-units and txn-value are
negative)
		       ;; create/update sold-value-list and sold-basis-value-list
		       (if (and (gnc-numeric-negative-p txn-units)
				(gnc-numeric-negative-p txn-value))
			   (begin
			     (soldbasiscoll 'add commod-currency (gnc-numeric-abs txn-value))
			     (set! sold-value-list (append sold-value-list (list
(gnc-numeric-abs txn-value))))
			     (case basis-method
			       ((fifo-basis average-basis)
				(soldvaluecoll 'add commod-currency (get-basis-value basis-list
txn-units))
				(set! sold-basis-value-list (append sold-basis-value-list (list
(get-basis-value basis-list txn-units))))
				)
			       ((filo-basis)
				(soldvaluecoll 'add commod-currency (get-basis-value (reverse
basis-list) txn-units))
				(set! sold-basis-value-list (append sold-basis-value-list (list
(get-basis-value (reverse basis-list) txn-units))))
				)
			       )
			     )
			   )

		       (if (gnc-numeric-zero-p txn-value)
			   ;; zero txn-value implies an equity stock split/reverse split
			   (set! basis-list (basis-modify basis-list txn-units basis-method))
			   ;; otherwise usual basis-builder action for postive and negative
amounts
			   (set! basis-list (basis-builder basis-list txn-units
(gnc:gnc-monetary-amount
										 (exchange-fn (gnc:make-gnc-monetary 
											       commod-currency txn-value) 
											      currency)) basis-method))
			   )
		       (gnc:msg "basis-list is:" basis-list)
		       (gnc:msg "sold-basis-value-list is:" sold-basis-value-list)
		       (gnc:msg "sold-value-list is: "sold-value-list)

		       (for-each
			(lambda (s)
			  (cond
			   ((same-split? s split) 
			    (gnc:msg "amount " (gnc-numeric-to-double (xaccSplitGetAmount s))
				     " acct " (xaccAccountGetName (xaccSplitGetAccount s)) )
			    (gnc:msg "value " (gnc-numeric-to-double (xaccSplitGetValue s))
				     " in " (gnc-commodity-get-printname commod-currency)
				     " from " (xaccTransGetDescription (xaccSplitGetParent s)))
			    ;; now process each split entry for money in, money out, expenses
			    (cond
			     ((or include-gains (not (gnc-numeric-zero-p (xaccSplitGetAmount
s))))
			      (unitscoll 'add commodity (xaccSplitGetAmount s)) ;; Is the
stock transaction?
;; these lines do nothing, but are in a debug so I'm leaving it, just in
case. asw.			     
;;			      (if (< 0 (gnc-numeric-to-double
;;					(xaccSplitGetAmount s)))


;;				  (set! totalunits
;;					(+ totalunits
;;					   (gnc-numeric-to-double (xaccSplitGetAmount s))))
;;				  )


;;			      (set! totalunityears
;;				    (+ totalunityears 
;;				       (* (gnc-numeric-to-double (xaccSplitGetAmount s))
;;					  (gnc:date-year-delta 
;;					   (car (gnc-transaction-get-date-posted parent))
;;					   (current-time))))) 
			      (cond 
			       ((gnc-numeric-negative-p (xaccSplitGetValue s))
				(moneyoutcoll
				 'add commod-currency
				 (gnc-numeric-neg (xaccSplitGetValue s)))
				(gnc:msg "money out coll: " moneyoutcoll "///" (xaccSplitGetValue
s))
)
			       (else (moneyincoll 
				      'add commod-currency
				      (gnc-numeric-neg (xaccSplitGetValue s))))))))
			 
			   ((split-account-type? s ACCT-TYPE-EXPENSE)
			     (brokeragecoll 'add commod-currency (xaccSplitGetValue s))
			     (gnc:msg "brokeragecoll:" brokeragecoll "///" (xaccSplitGetValue
s))

)
			   ;; all dividends and Cap-Gain will be picked up here
			   ((split-account-type? s ACCT-TYPE-INCOME)
			     (dividendcoll 'add commod-currency (xaccSplitGetValue s))
			     (gnc:msg "dividendcoll:" dividendcoll "///" (xaccSplitGetValue
s))
)
			   )
			  )
			(xaccTransGetSplitList parent)
			)
		       )
		     )
		 )
	       )
	     (xaccAccountGetSplitList current)
	     )
;;          (gnc:debug "totalunits" totalunits)
;;          (gnc:debug "totalunityears" totalunityears)

	    ;; now we determine which price data to use, the pricelist or the
txn
	    ;; and if we have a choice, use whichever is newest.
	    (set! use-txn (if (not price) #t 
			      (if prefer-pricelist #f
				  (if (not (gnc:timepair-le txn-date (gnc-price-get-time price)))
				      #t #f))))

	    ;; okay we're using the txn, so make a new price, value etc. and
warn the user
	    (if use-txn
		(begin
		  (set! price (if (not (gnc-numeric-zero-p txn-units))
				  (gnc:make-gnc-monetary commod-currency
							 (gnc-numeric-div txn-value
									  (gnc-numeric-abs txn-units)
									  100 GNC-RND-ROUND))
				  (gnc:make-gnc-monetary commod-currency (gnc-numeric-zero))))

		  (set! value (if price (gnc:make-gnc-monetary commod-currency 
						     (gnc-numeric-mul units
								      (gnc:gnc-monetary-amount price)
								      100 GNC-RND-ROUND))
				  (gnc:make-gnc-monetary commod-currency (gnc-numeric-zero))))
		  (set! warn-price-dirty #t)
		  )  
		)

	    ;; what this means is gain = moneyout - moneyin +
basis-of-current-shares, and
	    ;; adjust for brokers and dividends.
	    (gnc:msg "Other sum-basis -- basis-list " basis-list)
	    (gaincoll 'add currency (sum-basis basis-list))
            ;;(moneyincoll 'minusmerge dividendcoll #f)
	    ;;(moneyoutcoll 'minusmerge brokeragecoll #f)
	    (gaincoll 'merge moneyoutcoll #f)
	    (gaincoll 'merge moneyincoll #f)
	    (gnc:msg "moneyincoll is " (gnc:sum-collector-commodity moneyincoll
currency exchange-fn))
	    (gnc:msg "moneyoutcoll is " (gnc:sum-collector-commodity
moneyoutcoll currency exchange-fn))
	    (gnc:msg "gaincoll is " (gnc:sum-collector-commodity gaincoll
currency exchange-fn))
	    (gnc:msg "soldbasiscoll is " (gnc:sum-collector-commodity
soldbasiscoll currency exchange-fn))
	    (gnc:msg "soldvaluecoll is " (gnc:sum-collector-commodity
soldvaluecoll currency exchange-fn))


	    
	  (if (or include-empty (not (gnc-numeric-zero-p units)))
	    (let* (
		   (moneyin (gnc:monetary-neg
			     (gnc:sum-collector-commodity moneyincoll currency exchange-fn)))
		   (moneyout (gnc:sum-collector-commodity moneyoutcoll currency
exchange-fn))
		   ;; just so you know, gain == realized gain, ugain == un-realized
gain, bothgain, well..
		   (gain (gnc:sum-collector-commodity gaincoll currency exchange-fn))
		   (ugain (gnc:make-gnc-monetary currency 
						 (gnc-numeric-sub (gnc:gnc-monetary-amount (exchange-fn value
currency))
								  (sum-basis basis-list) 
								  100 GNC-RND-ROUND)))
		   (bothgain (gnc:make-gnc-monetary currency  (gnc-numeric-add
(gnc:gnc-monetary-amount gain)
									       (gnc:gnc-monetary-amount ugain)
									       100 GNC-RND-ROUND)))

		   (activecols (list (gnc:html-account-anchor current)))
		   )

	      (total-value 'add (gnc:gnc-monetary-commodity value)
(gnc:gnc-monetary-amount value))
	      (total-moneyin 'merge moneyincoll #f)
	      (total-moneyout 'merge moneyoutcoll #f)
	      (total-gain 'merge gaincoll #f)
	      (total-ugain 'add (gnc:gnc-monetary-commodity ugain)
(gnc:gnc-monetary-amount ugain))
	      (gnc:msg "call sum-basis " basis-list)
	      (total-basis 'add currency (sum-basis basis-list))
	      (gnc:msg "total-basis is " total-basis)
	      (gnc:msg "total-basis is " (gnc:sum-collector-commodity
total-basis currency exchange-fn))

	      ;; build a list for the row  based on user selections
	      (if show-symbol (append! activecols (list ticker-symbol)))
	      (if show-listing (append! activecols (list listing)))
	      (if show-shares (append! activecols (list
(gnc:make-html-table-header-cell/markup
 	        "number-cell" (xaccPrintAmount units share-print-info)))))
	      (if show-price (append! activecols (list
(gnc:make-html-table-header-cell/markup
	        "number-cell"
	        (if use-txn
		    (gnc:html-transaction-anchor
		     pricing-txn
		     price
		     )
	 	    (gnc:html-price-anchor
	 	     price
	 	     (gnc:make-gnc-monetary
	  	     (gnc-price-get-currency price)
		     (gnc-price-get-value price)))
		    )))))
 	      (append! activecols (list (if use-txn "*" " ")
					(gnc:make-html-table-header-cell/markup 
					 "number-cell" (gnc:make-gnc-monetary currency (sum-basis
basis-list)))
					(gnc:make-html-table-header-cell/markup "number-cell" value)
					(gnc:make-html-table-header-cell/markup "number-cell" moneyin)
					(gnc:make-html-table-header-cell/markup "number-cell" moneyout)
					(gnc:make-html-table-header-cell/markup "number-cell" gain)
					(gnc:make-html-table-header-cell/markup "number-cell" ugain)
					(gnc:make-html-table-header-cell/markup "number-cell" bothgain)
										
										
					(gnc:make-html-table-header-cell/markup "number-cell" 
					    (let ((moneyinvalue (gnc-numeric-to-double
								 (gnc:gnc-monetary-amount moneyin))))
					      (if (= 0.0 moneyinvalue)
						  (sprintf #f "%.2f%%" moneyinvalue)
						  (sprintf #f "%.2f%%" (* 100 (/ (gnc-numeric-to-double
									     (gnc:gnc-monetary-amount bothgain))
									    moneyinvalue))))))
					 )
			)
                       
	      (gnc:html-table-append-row/markup!
	       table
	       row-style
	       activecols)
	        
	      (table-add-stock-rows-internal rest (not odd-row?))
	      )
	    (table-add-stock-rows-internal rest odd-row?)
            )
            (gnc-price-list-destroy price-list)
	    )))

    (set! work-to-do (gnc:accounts-count-splits accounts))
    (table-add-stock-rows-internal accounts #t)))
  
  ;; Tell the user that we're starting.
  (gnc:report-starting reportname)

  ;; The first thing we do is make local variables for all the specific
  ;; options in the set of options given to the function. This set will
  ;; be generated by the options generator above.
  (let ((to-date     (gnc:date-option-absolute-time
                      (get-option gnc:pagename-general "Date")))
        (accounts    (get-option gnc:pagename-accounts "Accounts"))
        (currency    (get-option gnc:pagename-general "Report
Currency"))
        (price-source (get-option gnc:pagename-general
                                  optname-price-source))
        (report-title (get-option gnc:pagename-general 
                                  gnc:optname-reportname))
        (include-empty (get-option gnc:pagename-accounts
                                  optname-zero-shares))
        (include-gains (get-option gnc:pagename-general
                                  optname-include-gains))
	(show-symbol (get-option gnc:pagename-display
				  optname-show-symbol))
	(show-listing (get-option gnc:pagename-display
				  optname-show-listing))
	(show-shares (get-option gnc:pagename-display
				  optname-show-shares))
	(show-price (get-option gnc:pagename-display
				  optname-show-price))
	(basis-method (get-option gnc:pagename-general
				  optname-basis-method))
	(prefer-pricelist (get-option gnc:pagename-general
				      optname-prefer-pricelist))

	(total-basis (gnc:make-commodity-collector))
        (total-value    (gnc:make-commodity-collector))
        (total-moneyin  (gnc:make-commodity-collector))
        (total-moneyout (gnc:make-commodity-collector))
        (total-gain     (gnc:make-commodity-collector)) ;; realized gain
	(total-ugain (gnc:make-commodity-collector))    ;; unrealized gain
	;;document will be the HTML document that we return.
        (table (gnc:make-html-table))
        (document (gnc:make-html-document)))

    (gnc:html-document-set-title!
     document (string-append 
               report-title
               (sprintf #f " %s" (gnc-print-date to-date))))

    (if (not (null? accounts))
        ; at least 1 account selected
        (let* ((exchange-fn (gnc:case-exchange-fn price-source currency
to-date))
               (pricedb (gnc-pricedb-get-db (gnc-get-current-book)))
               (price-fn
                (case price-source
                  ((pricedb-latest) 
                   (lambda (foreign date) 
                    (gnc-pricedb-lookup-latest-any-currency pricedb
foreign)))
                  ((pricedb-nearest) 
                   (lambda (foreign date) 
                    (gnc-pricedb-lookup-nearest-in-time-any-currency
		     pricedb foreign (timespecCanonicalDayTime date))))
		  ((pricedb-latest-before)
		   (lambda (foreign date)
		     (gnc-pricedb-lookup-latest-before-any-currency
		      pricedb foreign (timespecCanonicalDayTime date))))))
	       (headercols (list (_ "Account")))
	       (totalscols (list (gnc:make-html-table-cell/markup
"total-label-cell" (_ "Total"))))
	       (sum-total-both-gains (gnc-numeric-zero))
	       (sum-total-gain (gnc-numeric-zero))
	       (sum-total-ugain (gnc-numeric-zero)))

	  ;;begin building lists for which columns to display
          (if show-symbol 
	      (begin (append! headercols (list (_ "Symbol")))
		     (append! totalscols (list " "))))

	  (if show-listing 
	      (begin (append! headercols (list (_ "Listing")))
		     (append! totalscols (list " "))))

	  (if show-shares 
	      (begin (append! headercols (list (_ "Shares")))
		     (append! totalscols (list " "))))

	  (if show-price 
	      (begin (append! headercols (list (_ "Price")))
		     (append! totalscols (list " "))))

	  (append! headercols (list " "
				    (_ "Basis")
				    (_ "Value")
				    (_ "Money In")
				    (_ "Money Out")
				    (_ "Realized Gain")
				    (_ "Unrealized Gain")
				    (_ "Total Gain")
				    (_ "Total Return")))

          (append! totalscols (list " "))

          (gnc:html-table-set-col-headers!
           table
	   headercols)
          
          (table-add-stock-rows
           table accounts to-date currency price-fn exchange-fn
           include-empty include-gains show-symbol show-listing
show-shares show-price 
	   basis-method prefer-pricelist total-basis total-value total-moneyin
total-moneyout total-gain total-ugain)
	  

	  (set! sum-total-gain (gnc:sum-collector-commodity total-gain currency
exchange-fn))
	  (set! sum-total-ugain (gnc:sum-collector-commodity total-ugain
currency exchange-fn))
	  (set! sum-total-both-gains (gnc:make-gnc-monetary currency
(gnc-numeric-add (gnc:gnc-monetary-amount sum-total-gain)
										      (gnc:gnc-monetary-amount sum-total-ugain)
										      100 GNC-RND-ROUND)))

          (gnc:html-table-append-row/markup!
           table
           "grand-total"
           (list
            (gnc:make-html-table-cell/size
             1 14 (gnc:make-html-text (gnc:html-markup-hr)))))

	  ;; finish building the totals columns, now that totals are complete
	  (append! totalscols (list
			       (gnc:make-html-table-cell/markup
				"total-number-cell" (gnc:sum-collector-commodity total-basis
currency exchange-fn))
			       (gnc:make-html-table-cell/markup
				"total-number-cell" (gnc:sum-collector-commodity total-value
currency exchange-fn))
			       (gnc:make-html-table-cell/markup
				"total-number-cell" (gnc:monetary-neg (gnc:sum-collector-commodity
total-moneyin currency exchange-fn)))
			       (gnc:make-html-table-cell/markup
				"total-number-cell" (gnc:sum-collector-commodity total-moneyout
currency exchange-fn))
			       (gnc:make-html-table-cell/markup
				"total-number-cell" sum-total-gain)
			       (gnc:make-html-table-cell/markup
				"total-number-cell" sum-total-ugain)
			       (gnc:make-html-table-cell/markup
				"total-number-cell" sum-total-both-gains)
			       (gnc:make-html-table-cell/markup
				"total-number-cell" 
				(let ((totalinvalue (gnc-numeric-to-double
						     (gnc:gnc-monetary-amount (gnc:monetary-neg
(gnc:sum-collector-commodity 
									       total-moneyin currency exchange-fn))))))
				  (if (= 0.0 totalinvalue) 
				      (sprintf #f "%.2f%%" totalinvalue) 
				      (sprintf #f "%.2f%%" (* 100 (/ (gnc-numeric-to-double
								      (gnc:gnc-monetary-amount sum-total-both-gains))
										   totalinvalue))))))
			       ))
	  

          (gnc:html-table-append-row/markup!
           table
           "grand-total"
           totalscols
            )

          (gnc:html-document-add-object! document table)
          (if warn-price-dirty 
              (gnc:html-document-append-objects! document 
                                                 (list
(gnc:make-html-text (_ "* this commodity data was built using
transaction pricing instead of the price list."))
						       (gnc:make-html-text (gnc:html-markup-br))
						       (gnc:make-html-text (_ "If you are in a multi-currency
situation, the exchanges may not be correct.")))))
)

					;if no accounts selected.
        (gnc:html-document-add-object!
         document
	 (gnc:html-make-no-account-warning 
	  report-title (gnc:report-id report-obj))))
    
    (gnc:report-finished)
    document)))

(gnc:define-report
 'version 1
 'name reportname
 'menu-path (list gnc:menuname-asset-liability)
 'options-generator options-generator
 'renderer advanced-portfolio-renderer)




More information about the gnucash-devel mailing list