1;; -*-scheme-*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;; portfolio.scm
3;; by Robert Merkel (rgmerk@mira.net)
4;;
5;; This program is free software; you can redistribute it and/or
6;; modify it under the terms of the GNU General Public License as
7;; published by the Free Software Foundation; either version 2 of
8;; the License, or (at your option) any later version.
9;;
10;; This program is distributed in the hope that it will be useful,
11;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13;; GNU General Public License for more details.
14;;
15;; You should have received a copy of the GNU General Public License
16;; along with this program; if not, contact:
17;;
18;; Free Software Foundation           Voice:  +1-617-542-5942
19;; 51 Franklin Street, Fifth Floor    Fax:    +1-617-542-2652
20;; Boston, MA  02110-1301,  USA       gnu@gnu.org
21;;
22;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23
24(define-module (gnucash reports standard portfolio))
25
26(use-modules (gnucash engine))
27(use-modules (gnucash utilities))
28(use-modules (gnucash core-utils))
29(use-modules (gnucash app-utils))
30(use-modules (gnucash report))
31(use-modules (srfi srfi-1))
32
33(define reportname (N_ "Investment Portfolio"))
34
35(define optname-price-source (N_ "Price Source"))
36(define optname-shares-digits (N_ "Share decimal places"))
37(define optname-zero-shares (N_ "Include accounts with no shares"))
38
39(define (options-generator)
40  (let* ((options (gnc:new-options))
41         ;; This is just a helper function for making options.
42         ;; See libgnucash/scm/options.scm for details.
43         (add-option
44          (lambda (new-option)
45            (gnc:register-option options new-option))))
46
47    ;; General Tab
48    ;; date at which to report balance
49    (gnc:options-add-report-date!
50     options gnc:pagename-general
51     (N_ "Date") "a")
52
53    (gnc:options-add-currency!
54     options gnc:pagename-general (N_ "Report's currency") "c")
55
56    (gnc:options-add-price-source!
57     options gnc:pagename-general
58     optname-price-source "d" 'pricedb-latest)
59
60    (add-option
61     (gnc:make-number-range-option
62      gnc:pagename-general optname-shares-digits
63      "e" (N_ "The number of decimal places to use for share numbers.") 2
64      0 9 0 1))
65
66    ;; Account tab
67    (add-option
68     (gnc:make-account-list-option
69      gnc:pagename-accounts (N_ "Accounts")
70      "b"
71      (N_ "Stock Accounts to report on.")
72      (lambda () (filter gnc:account-is-stock?
73                         (gnc-account-get-descendants-sorted
74                          (gnc-get-current-root-account))))
75      (lambda (accounts) (list  #t
76                                (filter gnc:account-is-stock? accounts)))
77      #t))
78
79    (gnc:register-option
80     options
81     (gnc:make-simple-boolean-option
82      gnc:pagename-accounts optname-zero-shares "e"
83      (N_ "Include accounts that have a zero share balances.")
84      #f))
85
86    (gnc:options-set-default-section options gnc:pagename-general)
87    options))
88
89;; This is the rendering function. It accepts a database of options
90;; and generates an object of type <html-document>.  See the file
91;; report-html.txt for documentation; the file report-html.scm
92;; includes all the relevant Scheme code. The option database passed
93;; to the function is one created by the options-generator function
94;; defined above.
95(define (portfolio-renderer report-obj)
96
97 (let ((work-done 0)
98       (work-to-do 0))
99
100  ;; These are some helper functions for looking up option values.
101  (define (get-op section name)
102    (gnc:lookup-option (gnc:report-options report-obj) section name))
103
104  (define (get-option section name)
105    (gnc:option-value (get-op section name)))
106
107  (define (table-add-stock-rows table accounts to-date currency
108                                exchange-fn price-fn include-empty collector)
109
110   (let ((share-print-info
111	  (gnc-share-print-info-places
112	   (inexact->exact (get-option gnc:pagename-general
113				       optname-shares-digits)))))
114
115    (define (table-add-stock-rows-internal accounts odd-row?)
116      (if (null? accounts) collector
117          (let* ((row-style (if odd-row? "normal-row" "alternate-row"))
118                 (current (car accounts))
119                 (rest (cdr accounts))
120                 (commodity (xaccAccountGetCommodity current))
121                 (ticker-symbol (gnc-commodity-get-mnemonic commodity))
122                 (listing (gnc-commodity-get-namespace commodity))
123                 (unit-collector (gnc:account-get-comm-balance-at-date
124                                  current to-date #f))
125                 (units (cadr (unit-collector 'getpair commodity #f)))
126
127                 (price-info (price-fn commodity to-date))
128                 (price (car price-info))
129                 (price-monetary (if price
130                                     (gnc:make-gnc-monetary
131                                      (gnc-price-get-currency price)
132                                      (gnc-price-get-value price))
133                                     (gnc:make-gnc-monetary
134                                      currency
135                                      (cdr price-info))))
136                 (value (exchange-fn (gnc:make-gnc-monetary commodity units)
137                                     currency)))
138
139	    (set! work-done (+ 1 work-done))
140	    (gnc:report-percent-done (* 100 (/ work-done work-to-do)))
141	    (if (or include-empty (not (gnc-numeric-zero-p units)))
142		(begin (collector 'add currency (gnc:gnc-monetary-amount value))
143		       (gnc:html-table-append-row/markup!
144			table
145			row-style
146			(list (gnc:html-account-anchor current)
147			      (gnc:make-html-table-header-cell/markup "text-cell" ticker-symbol)
148			      (gnc:make-html-table-header-cell/markup "text-cell" listing)
149			      (gnc:make-html-table-header-cell/markup
150			       "number-cell"
151			       (xaccPrintAmount units share-print-info))
152			      (gnc:make-html-table-header-cell/markup
153			       "number-cell"
154                               (gnc:html-price-anchor price price-monetary))
155			      (gnc:make-html-table-header-cell/markup
156			       "number-cell" value)))
157		       ;;(display (format #f "Shares: ~6d  " (gnc-numeric-to-double units)))
158		       ;;(display units) (newline)
159		       (if price (gnc-price-unref price))
160		       (table-add-stock-rows-internal rest (not odd-row?)))
161		(begin (if price (gnc-price-unref price))
162		       (table-add-stock-rows-internal rest odd-row?))))))
163
164    (set! work-to-do (length accounts))
165    (table-add-stock-rows-internal accounts #t)))
166
167  ;; Tell the user that we're starting.
168  (gnc:report-starting reportname)
169
170  ;; The first thing we do is make local variables for all the specific
171  ;; options in the set of options given to the function. This set will
172  ;; be generated by the options generator above.
173  (let ((to-date     (gnc:time64-end-day-time
174                      (gnc:date-option-absolute-time
175                       (get-option gnc:pagename-general "Date"))))
176        (accounts    (get-option gnc:pagename-accounts "Accounts"))
177        (currency    (get-option gnc:pagename-general "Report's currency"))
178        (report-title (get-option gnc:pagename-general
179                                  gnc:optname-reportname))
180        (price-source (get-option gnc:pagename-general
181                                  optname-price-source))
182        (include-empty (get-option gnc:pagename-accounts
183                                  optname-zero-shares))
184
185        (collector   (gnc:make-commodity-collector))
186        ;; document will be the HTML document that we return.
187        (table (gnc:make-html-table))
188        (document (gnc:make-html-document)))
189
190    (gnc:html-document-set-title!
191     document (string-append
192               report-title
193               (format #f " ~a" (qof-print-date to-date))))
194
195    ;(gnc:debug "accounts" accounts)
196    (if (not (null? accounts))
197        (let* ((commodity-list (gnc:accounts-get-commodities
198                                (gnc:accounts-and-all-descendants accounts)
199                                currency))
200               (pricedb (gnc-pricedb-get-db (gnc-get-current-book)))
201	       (exchange-fn (gnc:case-exchange-fn price-source currency to-date))
202               (price-fn
203                (case price-source
204                  ((weighted-average average-cost)
205                   (lambda (foreign date)
206                    (cons #f (gnc-numeric-div
207                               (gnc:gnc-monetary-amount
208                                  (exchange-fn (gnc:make-gnc-monetary foreign
209                                                  (gnc-numeric-create 10000 1))
210                                                  currency))
211                               (gnc-numeric-create 10000 1)
212                               GNC-DENOM-AUTO
213                               (logior (GNC-DENOM-SIGFIGS 5) GNC-RND-ROUND)))))
214                  ((pricedb-latest)
215                   (lambda (foreign date)
216                     (let* ((price
217                             (gnc-pricedb-lookup-latest-any-currency
218                              pricedb foreign))
219                            (fn (if (and price (> (length price) 0))
220                                    (let* ((the_price
221                                            (if (gnc-commodity-equiv
222                                                 foreign
223                                                 (gnc-price-get-commodity (car price)))
224                                                (car price)
225                                                (gnc-price-invert (car price))))
226                                           (v (gnc-price-get-value the_price)))
227                                          (gnc-price-ref (car price))
228                                          (cons (car price) v))
229                                        (cons #f (gnc-numeric-zero)))))
230                       (if price (gnc-price-list-destroy price))
231                       fn)))
232                  ((pricedb-nearest)
233                   (lambda (foreign date)
234                     (let*  ((price
235                             (gnc-pricedb-lookup-nearest-in-time-any-currency-t64
236                              pricedb foreign (time64CanonicalDayTime date)))
237                            (fn (if (and price (> (length price) 0))
238                                    (let* ((the_price
239                                            (if (gnc-commodity-equiv
240                                                 foreign
241                                                 (gnc-price-get-commodity (car price)))
242                                                (car price)
243                                                (gnc-price-invert (car price))))
244                                           (v (gnc-price-get-value (car price))))
245                                           (gnc-price-ref (car price))
246                                           (cons (car price) v))
247                                         (cons #f (gnc-numeric-zero)))))
248                       (if price (gnc-price-list-destroy price))
249                       fn))))))
250
251          (gnc:html-table-set-col-headers!
252           table
253           (list (G_ "Account")
254                 (G_ "Symbol")
255                 (G_ "Listing")
256                 (G_ "Units")
257                 (G_ "Price")
258                 (G_ "Value")))
259
260          (table-add-stock-rows
261           table accounts to-date currency
262           exchange-fn price-fn include-empty collector)
263
264          (gnc:html-table-append-row/markup!
265           table
266           "grand-total"
267           (list
268            (gnc:make-html-table-cell/size
269             1 6 (gnc:make-html-text (gnc:html-markup-hr)))))
270
271          (collector
272           'format
273           (lambda (currency amount)
274             (gnc:html-table-append-row/markup!
275              table
276              "grand-total"
277              (list (gnc:make-html-table-cell/markup
278                     "total-label-cell" (G_ "Total"))
279                    (gnc:make-html-table-cell/size/markup
280                     1 5 "total-number-cell"
281                     (gnc:make-gnc-monetary currency amount)))))
282           #f)
283
284          (gnc:html-document-add-object! document table))
285
286                                        ;if no accounts selected.
287        (gnc:html-document-add-object!
288         document
289	 (gnc:html-make-no-account-warning
290	  report-title (gnc:report-id report-obj))))
291
292    (gnc:report-finished)
293    document)))
294
295(gnc:define-report
296 'version 1
297 'name reportname
298 'report-guid "4a6b82e8678c4f3d9e85d9f09634ca89"
299 'menu-path (list gnc:menuname-asset-liability)
300 'options-generator options-generator
301 'renderer portfolio-renderer)
302