scheme help - keeping the 1.8 advanced-portfolio.scm working?
Oliver Iberien
odilist at sonic.net
Tue Nov 6 03:09:04 EST 2007
I've been using the version of advanced-portfolio.scm from 1.8 as the
subsequent ones return garbage for accounts with split transactions.
Having just upgraded to 2.2.1 on Ubuntu 7.10, I find that this .scm no
longer works -- it crashes Gnucash. The backtrace follows. I've also
attached the old .scm file.
Can any of the scheme experts out there tell me if there any tweaking
that can be done to this to get it to continue to work?
Thanks,
Oliver
Backtrace:
In unknown file:
?: 0* [#<procedure #f (window)> #<swig-pointer GncMainWindow *
81fa000>]
In /usr/share/gnucash/guile-modules/gnucash/report/report-gnome.scm:
79: 1* (let ((report #)) (gnc-main-window-open-report report window))
79: 2* [gnc:make-report "Advanced Portfolio"]
In /usr/share/gnucash/scm/report.scm:
244: 3 (let (# #) (let # # #) (gnc:report-set-id! r #) ...)
255: 4* (let ((options (if # # ...))) (gnc:report-set-options! r
options) ...)
256: 5* (if (not (null? rest)) (car rest) ...)
258: 6 [gnc:report-template-new-options #]
...
176: 7 (let ((options (generator))) (gnc:register-option options
stylesheet) ...)
176: 8* [options-generator]
In /usr/share/gnucash/guile-modules/gnucash/report/advanced-portfolio.scm:
47: 9 (let* # # # ...)
90: 10* [#<procedure #f (new-option)> ...
91: 11* [gnc:make-account-list-option "Accounts" "Accounts" ...]
In /usr/share/gnucash/scm/options.scm:
594: 12 [gnc:make-account-list-limited-option "Accounts" "Accounts" ...]
...
625: 13 (let* (# # # # ...) (gnc:make-option section name sort-tag ...))
625: 14* [map #<procedure convert-to-guid (item)> ...
625: 15* [#<procedure #f ()>]
In /usr/share/gnucash/guile-modules/gnucash/report/advanced-portfolio.scm:
95: 16 [filter #<procedure gnc:account-is-stock? (account)> ...
96: 17* (gnc:group-get-subaccounts (gnc:get-current-group))
/usr/share/gnucash/guile-modules/gnucash/report/advanced-portfolio.scm:96:26:
In expression (gnc:group-get-subaccounts (gnc:get-current-group)):
/usr/share/gnucash/guile-modules/gnucash/report/advanced-portfolio.scm:96:26:
Unbound variable: gnc:group-get-subaccounts
;; -*-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
;; 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))
(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"))
(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 (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"))
)))
(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-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)))
(define (table-add-stock-rows table accounts to-date
currency price-fn exchange-fn
include-empty include-gains
total-value total-moneyin total-moneyout
total-gain)
(let ((share-print-info
(gnc:share-print-info-places (get-option gnc:pagename-general
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 (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))
(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)
(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: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
(gnc:make-gnc-monetary
(gnc:price-get-currency price)
(gnc:price-get-value price)))
#f))
(gnc:make-html-table-header-cell/markup
"number-cell" value)
(gnc:make-html-table-header-cell/markup
"number-cell" (gnc:monetary-neg
(gnc:sum-collector-commodity moneyincoll currency exchange-fn)))
(gnc:make-html-table-header-cell/markup
"number-cell"
(gnc:sum-collector-commodity moneyoutcoll currency exchange-fn))
(gnc:make-html-table-header-cell/markup
"number-cell"
(gnc:sum-collector-commodity gaincoll currency exchange-fn))
(gnc:make-html-table-header-cell/markup
"number-cell" (sprintf #f "%.2f%%" (*
100 (/ (gnc:numeric-to-double (cadr (gaincoll 'getpair currency #f)))
(gnc:numeric-to-double (cadr (moneyincoll 'getpair currency #t)))))))
)
)
(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))
(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 1 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
table 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-renderer)
More information about the gnucash-user
mailing list