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