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