mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
* src/scm/report/portfolio.scm: convert to guile module.
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@4744 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Rob Browning
parent
f375b0c95a
commit
785107263d
@ -21,210 +21,212 @@
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(gnc:support "report/portfolio.scm")
|
||||
;; depends must be outside module scope -- and should eventually go away.
|
||||
(gnc:depend "report-html.scm")
|
||||
|
||||
(let ((optname-price-source (N_ "Price Source")))
|
||||
(define-module (gnucash report portfolio))
|
||||
|
||||
(define optname-price-source (N_ "Price Source"))
|
||||
|
||||
(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")
|
||||
|
||||
(gnc:options-add-price-source!
|
||||
options gnc:pagename-general
|
||||
optname-price-source "d" 'pricedb-latest)
|
||||
|
||||
;; 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: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 (portfolio-renderer report-obj)
|
||||
|
||||
(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))))
|
||||
;; 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 (table-add-stock-rows table accounts to-date
|
||||
currency price-fn collector)
|
||||
|
||||
;; General Tab
|
||||
;; date at which to report balance
|
||||
(gnc:options-add-report-date!
|
||||
options gnc:pagename-general
|
||||
(N_ "Date") "a")
|
||||
(define (table-add-stock-rows-internal accounts odd-row?)
|
||||
(if (null? accounts) collector
|
||||
(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)))
|
||||
|
||||
(gnc:options-add-currency!
|
||||
options gnc:pagename-general (N_ "Report Currency") "c")
|
||||
(price-value (price-fn commodity currency to-date))
|
||||
|
||||
(value-num (gnc:numeric-mul
|
||||
units
|
||||
price-value
|
||||
(gnc:commodity-get-fraction currency)
|
||||
GNC-RND-ROUND))
|
||||
|
||||
(gnc:options-add-price-source!
|
||||
options gnc:pagename-general
|
||||
optname-price-source "d" 'pricedb-latest)
|
||||
(value (gnc:make-gnc-monetary currency value-num)))
|
||||
(collector 'add currency value-num)
|
||||
(gnc:html-table-append-row/markup!
|
||||
table
|
||||
row-style
|
||||
(list name
|
||||
ticker-symbol
|
||||
listing
|
||||
(gnc:make-html-table-header-cell/markup
|
||||
"number-cell" (gnc:numeric-to-double units))
|
||||
(gnc:make-html-table-header-cell/markup
|
||||
"number-cell" (gnc:make-gnc-monetary currency
|
||||
price-value))
|
||||
(gnc:make-html-table-header-cell/markup
|
||||
"number-cell" value)))
|
||||
(table-add-stock-rows-internal rest (not odd-row?)))))
|
||||
|
||||
;; 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))
|
||||
(table-add-stock-rows-internal accounts #t))
|
||||
|
||||
(gnc:options-set-default-section options gnc:pagename-general)
|
||||
options))
|
||||
;; 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"))
|
||||
(report-title (get-option gnc:pagename-general
|
||||
gnc:optname-reportname))
|
||||
(price-source (get-option gnc:pagename-general
|
||||
optname-price-source))
|
||||
|
||||
;; 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 (portfolio-renderer report-obj)
|
||||
(collector (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:timepair-to-datestring to-date))))
|
||||
|
||||
(gnc:debug "accounts" accounts)
|
||||
(if (not (null? accounts))
|
||||
(let* ((commodity-list (gnc:accounts-get-commodities
|
||||
(append
|
||||
(gnc:acccounts-get-all-subaccounts
|
||||
accounts) accounts) currency))
|
||||
(pricedb (gnc:book-get-pricedb (gnc:get-current-book)))
|
||||
(price-fn
|
||||
(case price-source
|
||||
('weighted-average
|
||||
(let ((pricealist
|
||||
(gnc:get-commoditylist-totalavg-prices
|
||||
commodity-list currency to-date)))
|
||||
(lambda (foreign domestic date)
|
||||
(gnc:pricealist-lookup-nearest-in-time
|
||||
pricealist foreign date))))
|
||||
('pricedb-latest
|
||||
(lambda (foreign domestic date)
|
||||
(let ((price
|
||||
(gnc:pricedb-lookup-latest
|
||||
pricedb foreign domestic)))
|
||||
(if price
|
||||
(let ((v (gnc:price-get-value price)))
|
||||
(gnc:price-unref price)
|
||||
v)
|
||||
(gnc:numeric-zero)))))
|
||||
('pricedb-nearest
|
||||
(lambda (foreign domestic date)
|
||||
(let ((price
|
||||
(gnc:pricedb-lookup-nearest-in-time
|
||||
pricedb foreign domestic date)))
|
||||
(if price
|
||||
(let ((v (gnc:price-get-value price)))
|
||||
(gnc:price-unref price)
|
||||
v)
|
||||
(gnc:numeric-zero))))))))
|
||||
|
||||
(gnc:html-table-set-col-headers!
|
||||
table
|
||||
(list (_ "Account")
|
||||
(_ "Symbol")
|
||||
(_ "Listing")
|
||||
(_ "Units")
|
||||
(_ "Price")
|
||||
(_ "Value")))
|
||||
|
||||
(table-add-stock-rows
|
||||
table accounts to-date currency
|
||||
price-fn collector)
|
||||
|
||||
(gnc:html-table-append-row/markup!
|
||||
table
|
||||
"grand-total"
|
||||
(list
|
||||
(gnc:make-html-table-cell/size
|
||||
1 6 (gnc:make-html-text (gnc:html-markup-hr)))))
|
||||
|
||||
(collector
|
||||
'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)))
|
||||
|
||||
;; 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 (table-add-stock-rows table accounts to-date
|
||||
currency price-fn collector)
|
||||
document))
|
||||
|
||||
(define (table-add-stock-rows-internal accounts odd-row?)
|
||||
(if (null? accounts) collector
|
||||
(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)))
|
||||
|
||||
(price-value (price-fn commodity currency to-date))
|
||||
|
||||
(value-num (gnc:numeric-mul
|
||||
units
|
||||
price-value
|
||||
(gnc:commodity-get-fraction currency)
|
||||
GNC-RND-ROUND))
|
||||
|
||||
(value (gnc:make-gnc-monetary currency value-num)))
|
||||
(collector 'add currency value-num)
|
||||
(gnc:html-table-append-row/markup!
|
||||
table
|
||||
row-style
|
||||
(list name
|
||||
ticker-symbol
|
||||
listing
|
||||
(gnc:make-html-table-header-cell/markup
|
||||
"number-cell" (gnc:numeric-to-double units))
|
||||
(gnc:make-html-table-header-cell/markup
|
||||
"number-cell" (gnc:make-gnc-monetary currency
|
||||
price-value))
|
||||
(gnc:make-html-table-header-cell/markup
|
||||
"number-cell" value)))
|
||||
(table-add-stock-rows-internal rest (not odd-row?)))))
|
||||
|
||||
(table-add-stock-rows-internal accounts #t))
|
||||
|
||||
;; 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"))
|
||||
(report-title (get-option gnc:pagename-general
|
||||
gnc:optname-reportname))
|
||||
(price-source (get-option gnc:pagename-general
|
||||
optname-price-source))
|
||||
|
||||
(collector (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:timepair-to-datestring to-date))))
|
||||
|
||||
(gnc:debug "accounts" accounts)
|
||||
(if (not (null? accounts))
|
||||
(let* ((commodity-list (gnc:accounts-get-commodities
|
||||
(append
|
||||
(gnc:acccounts-get-all-subaccounts
|
||||
accounts) accounts) currency))
|
||||
(pricedb (gnc:book-get-pricedb (gnc:get-current-book)))
|
||||
(price-fn
|
||||
(case price-source
|
||||
('weighted-average
|
||||
(let ((pricealist
|
||||
(gnc:get-commoditylist-totalavg-prices
|
||||
commodity-list currency to-date)))
|
||||
(lambda (foreign domestic date)
|
||||
(gnc:pricealist-lookup-nearest-in-time
|
||||
pricealist foreign date))))
|
||||
('pricedb-latest
|
||||
(lambda (foreign domestic date)
|
||||
(let ((price
|
||||
(gnc:pricedb-lookup-latest
|
||||
pricedb foreign domestic)))
|
||||
(if price
|
||||
(let ((v (gnc:price-get-value price)))
|
||||
(gnc:price-unref price)
|
||||
v)
|
||||
(gnc:numeric-zero)))))
|
||||
('pricedb-nearest
|
||||
(lambda (foreign domestic date)
|
||||
(let ((price
|
||||
(gnc:pricedb-lookup-nearest-in-time
|
||||
pricedb foreign domestic date)))
|
||||
(if price
|
||||
(let ((v (gnc:price-get-value price)))
|
||||
(gnc:price-unref price)
|
||||
v)
|
||||
(gnc:numeric-zero))))))))
|
||||
|
||||
(gnc:html-table-set-col-headers!
|
||||
table
|
||||
(list (_ "Account")
|
||||
(_ "Symbol")
|
||||
(_ "Listing")
|
||||
(_ "Units")
|
||||
(_ "Price")
|
||||
(_ "Value")))
|
||||
|
||||
(table-add-stock-rows
|
||||
table accounts to-date currency
|
||||
price-fn collector)
|
||||
|
||||
(gnc:html-table-append-row/markup!
|
||||
table
|
||||
"grand-total"
|
||||
(list
|
||||
(gnc:make-html-table-cell/size
|
||||
1 6 (gnc:make-html-text (gnc:html-markup-hr)))))
|
||||
|
||||
(collector
|
||||
'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)))
|
||||
|
||||
|
||||
document))
|
||||
|
||||
(gnc:define-report
|
||||
'version 1
|
||||
'name (N_ "Investment Portfolio")
|
||||
'menu-path (list gnc:menuname-asset-liability)
|
||||
'options-generator options-generator
|
||||
'renderer portfolio-renderer))
|
||||
(gnc:define-report
|
||||
'version 1
|
||||
'name (N_ "Investment Portfolio")
|
||||
'menu-path (list gnc:menuname-asset-liability)
|
||||
'options-generator options-generator
|
||||
'renderer portfolio-renderer)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user