advanced-portfolio-sorted
Johan van Oostrum
jo.vanoost at wanadoo.nl
Wed Jan 17 13:50:20 EST 2007
Hi all,
The following hack may be of interest for those who quickly want an
overview of their over/underperforming stocks. It is a slightly
modified version of the advanced-portfolio report. Added is an option
to choosea column the report should be sorted upon. I decided to name
it advanced-portfolio-sorted to enable users to give it a try without
removing the original report. Slight drawback of this approach is that
one has to edit standard-reports.scm.
I would never have had the courage to start writing Scheme without the
help of drScheme to balance parentheses. By the way, those of you
developing with scheme should have a look at drScheme, if not already
using this. http://www.drscheme.org/
Enfin, installation of the report (I use Fink and have the files
located here: /sw/share/gnucash/guile-modules/gnucash/report/)
* 1 * Copy the report code to advance-portfolio-sorted.scm
* 2 * Add the marked line in standard-reports.scm:
...
(use-modules (gnucash report advanced-portfolio))
(use-modules (gnucash report advanced-portfolio-sorted)) ;; this is the
new report
(use-modules (gnucash report average-balance))
...
* 3 * Following is the new report code:
;; -*-scheme-*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; advanced-portfolio-sorted.scm
;; by Johan van Oostrum (jvo at chaosgeordend.nl) Jan 2007
;;
;; This is a modified version of:
;; 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
;; Which in turn is 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
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu at gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report advanced-portfolio-sorted))
(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 Sorted"))
(define optname-price-source (N_ "Price Source"))
(define optname-sort-column (N_ "Sort Column"))
(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 (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-sort-column
"d" (N_ "The column on which the report is sorted") '0
(list (vector '0 (N_ "Account") (N_ ""))
(vector '1 (N_ "Symbol") (N_ ""))
(vector '2 (N_ "Listing") (N_ ""))
(vector '3 (N_ "Shares") (N_ ""))
(vector '4 (N_ "Price") (N_ ""))
(vector '5 (N_ "Value") (N_ ""))
(vector '6 (N_ "Money-in") (N_ ""))
(vector '7 (N_ "Money-out") (N_ ""))
(vector '8 (N_ "Gain") (N_ ""))
(vector '9 (N_ "Total return") (N_ ""))
)))
(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"))
)))
(add-option
(gnc:make-number-range-option
gnc:pagename-general optname-shares-digits
"e" (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-general optname-include-gains "f"
(N_ "Include splits with no shares for calculating money-in and
money-out")
#f))
;; 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:group-get-subaccounts
(gnc:get-current-group))))
(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-sorted-renderer report-obj)
(let ((work-done 0)
(work-to-do 0))
;; 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
(gw:enum-<gnc:AccountType>-val->sym (gnc:account-get-type
(gnc:split-get-account split)) #f)))
(define (same-split? s1 s2)
(string=? (gnc:split-get-guid s1) (gnc:split-get-guid s2)))
;; return list with computed values for all selected stocks
(define (table-add-stock-rows accounts to-date
currency price-fn exchange-fn
include-empty include-gains
total-value total-moneyin
total-moneyout total-gain)
(let ()
(define (table-add-stock-rows-internal accounts)
(if (null? accounts) (list) ; return empty list
(let* ((current (car accounts))
(rest (cdr accounts))
(name (gnc:account-get-name current))
(commodity (gnc:account-get-commodity 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)
(totalunityears 0.0)
;; 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))
(price-list (price-fn commodity to-date))
(price (if (> (length price-list) 0)
(car price-list)
#f))
(rate (if price
(gnc:make-gnc-monetary
(gnc:price-get-currency price)
(gnc:price-get-value price))
#f))
(value (exchange-fn (gnc:make-gnc-monetary
commodity units) currency to-date))
)
;; (gnc:debug "---" name "---")
(for-each
(lambda (split)
(set! work-done (+ 1 work-done))
(gnc:report-percent-done (* 100 (/ work-done
work-to-do)))
(let ((parent (gnc:split-get-parent split)))
(if (gnc:timepair-le
(gnc:transaction-get-date-posted parent) to-date)
(for-each
(lambda (s)
(cond
((same-split? s split)
;; (gnc:debug "amount"
(gnc:numeric-to-double (gnc:split-get-amount s)) )
(cond
((or include-gains (not
(gnc:numeric-zero-p (gnc:split-get-amount s))))
(unitscoll 'add commodity
(gnc:split-get-amount s)) ;; Is the stock transaction?
(if (< 0 (gnc:numeric-to-double
(gnc:split-get-amount s)))
(set! totalunits
(+ totalunits
(gnc:numeric-to-double
(gnc:split-get-amount s)))))
(set! totalunityears
(+ totalunityears
(* (gnc:numeric-to-double
(gnc:split-get-amount s))
(gnc:date-year-delta
(car
(gnc:transaction-get-date-posted parent))
(current-time)))))
(cond
((gnc:numeric-negative-p
(gnc:split-get-value s))
(moneyoutcoll
'add currency
(gnc:numeric-neg
(gnc:split-get-value s))))
(else (moneyincoll
'add currency
(gnc:numeric-neg
(gnc:split-get-value s))))))))
((split-account-type? s 'expense)
(brokeragecoll 'add currency
(gnc:split-get-value s)))
((split-account-type? s 'income)
(dividendcoll 'add currency
(gnc:split-get-value s)))
)
)
(gnc:transaction-get-splits parent)
)
)
)
)
(gnc:account-get-split-list current)
)
;; (gnc:debug "totalunits" totalunits)
;; (gnc:debug "totalunityears"
totalunityears)
(gaincoll 'merge moneyoutcoll #f)
(gaincoll 'add (gnc:gnc-monetary-commodity value)
(gnc:gnc-monetary-amount value))
(gaincoll 'merge moneyincoll #f)
(gnc:price-list-destroy price-list)
(if (or include-empty (not (gnc:numeric-zero-p units)))
(begin
(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)
;;(gnc:warn ">name: " (gnc:account-get-name
current))
;;(if price (gnc:warn ">price: "
(gnc:numeric-to-double (gnc:gnc-monetary-amount rate))))
(cons (list current
ticker-symbol
listing
units
rate
value
(gnc:monetary-neg
(gnc:sum-collector-commodity moneyincoll currency exchange-fn))
(gnc:sum-collector-commodity
moneyoutcoll currency exchange-fn)
(gnc:sum-collector-commodity gaincoll
currency exchange-fn)
(* 100 (/ (gnc:numeric-to-double
(cadr (gaincoll 'getpair currency #f)))
(gnc:numeric-to-double
(cadr (moneyincoll 'getpair currency #t)))))
price)
(table-add-stock-rows-internal rest)))
(table-add-stock-rows-internal rest)))
))
(set! work-to-do (gnc:accounts-count-splits accounts)) ;
#splits as progress indicator
(table-add-stock-rows-internal accounts)
))
;; add one row with stock-computed values to the HTML table
(define (table-add-stock-row-html table share-print-info odd-row?
current ticker-symbol listing
units
rate value money-in money-out
gain return price)
(let* ((row-style (if odd-row? "normal-row" "alternate-row"))
(odd-row? (not odd-row?)))
(gnc:html-table-append-row/markup!
table
row-style
(list (gnc:html-account-anchor current)
ticker-symbol
listing
(gnc:make-html-table-header-cell/markup "number-cell"
(gnc:amount->string units share-print-info))
(gnc:make-html-table-header-cell/markup
"number-cell"
(if price
(gnc:html-price-anchor price rate)
#f))
(gnc:make-html-table-header-cell/markup "number-cell"
value)
(gnc:make-html-table-header-cell/markup "number-cell"
money-in)
(gnc:make-html-table-header-cell/markup "number-cell"
money-out)
(gnc:make-html-table-header-cell/markup "number-cell"
gain)
(gnc:make-html-table-header-cell/markup "number-cell"
(sprintf #f "%.3f%%" return))
))))
;; add all computed values off all stocks selected to the HTML table
(define (table-add-stock-rows-html table account-totals)
(let*
;; get printing related options first
((share-print-info (gnc:share-print-info-places (get-option
gnc:pagename-general
optname-shares-digits)))
(c (get-option gnc:pagename-general
optname-sort-column))
(odd-row? #t))
(for-each
(lambda (l)
(apply table-add-stock-row-html table share-print-info
odd-row? l))
;; sort column (c in sort-list compare-less procedure) offsets
are:
;; 0 account
;; 1 symbol
;; 2 listing
;; 3 shares (units)
;; 4 price (rate)
;; 5 value
;; 6 money-in
;; 7 money-out
;; 8 gain
;; 9 total-return
(sort-list account-totals (cond
((= c 0)
(lambda (list1 list2)
(if (string<?
(gnc:account-get-name (list-ref list1 c))
(gnc:account-get-name (list-ref list2 c))) #t #f)))
((and (> c 0) (< c 3))
(lambda (list1 list2)
(if (string<? (list-ref list1
c) (list-ref list2 c)) #t #f)))
((= c 3)
(lambda (list1 list2)
(if (<
(gnc:numeric-to-double(list-ref list1 c))
(gnc:numeric-to-double(list-ref list2 c))) #t #f)))
((= c 4)
(lambda (list1 list2)
(if (< (if (list-ref list1 c)
(gnc:numeric-to-double (gnc:gnc-monetary-amount (list-ref list1 c)))
0.0)
(if (list-ref list2 c)
(gnc:numeric-to-double (gnc:gnc-monetary-amount (list-ref list2 c)))
0.0)) #t #f)))
((and (> c 4) (< c 9))
(lambda (list1 list2)
(if (< (gnc:numeric-to-double
(gnc:gnc-monetary-amount (list-ref list1 c)))
(gnc:numeric-to-double
(gnc:gnc-monetary-amount (list-ref list2 c)))) #t #f)))
((> c 8)
(lambda (list1 list2)
(if (< (list-ref list1 c)
(list-ref list2 c)) #t #f)))
)))))
;; 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))
(total-value (gnc:make-commodity-collector))
(total-moneyin (gnc:make-commodity-collector))
(total-moneyout (gnc:make-commodity-collector))
(total-gain (gnc:make-commodity-collector))
;; 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))))
;; (gnc:debug "accounts" accounts)
(if (not (null? accounts))
; at least one account selected
(let* ((exchange-fn
(case price-source
('pricedb-latest
(lambda (foreign domestic date)
(gnc:exchange-by-pricedb-latest foreign
domestic)))
('pricedb-nearest gnc:exchange-by-pricedb-nearest)))
(pricedb (gnc:book-get-pricedb (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
date))))))
(gnc:html-table-set-col-headers!
table
(list (_ "Account")
(_ "Symbol")
(_ "Listing")
(_ "Shares")
(_ "Price")
(_ "Value")
(_ "Money In")
(_ "Money Out")
(_ "Gain")
(_ "Total Return")))
(table-add-stock-rows-html table
(table-add-stock-rows accounts
to-date
currency
price-fn exchange-fn
include-empty include-gains
total-value total-moneyin total-moneyout total-gain))
(gnc:html-table-append-row/markup!
table
"grand-total"
(list
(gnc:make-html-table-cell/size
1 10 (gnc:make-html-text (gnc:html-markup-hr)))))
(gnc:html-table-append-row/markup!
table
"grand-total"
(list (gnc:make-html-table-cell/markup
"total-label-cell" (_ "Total"))
""
""
""
""
(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" (gnc:sum-collector-commodity
total-gain currency exchange-fn))
(gnc:make-html-table-cell/markup
"total-number-cell" (sprintf #f "%.2f%%" (* 100 (/
(gnc:numeric-to-double (cadr (total-gain 'getpair currency #f)))
(gnc:numeric-to-double (cadr (total-moneyin 'getpair currency #t)))))))
))
;; (total-value
;; 'format
;; (lambda (currency amount)
;; (gnc:html-table-append-row/markup!
;; table
;; "grand-total"
;; (list (gnc:make-html-table-cell/markup
;; "total-label-cell" (_ "Total"))
;; (gnc:make-html-table-cell/size/markup
;; 1 5 "total-number-cell"
;; (gnc:make-gnc-monetary currency
amount)))))
;; #f)
(gnc:html-document-add-object! document table))
;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-sorted-renderer)
More information about the gnucash-devel
mailing list