From e983d07cb12913740a38472baa98ed0eeea5dc7d Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Wed, 27 Jun 2018 19:29:40 +0800 Subject: [PATCH] [balsheet-pnl] Initial commit --- gnucash/report/report-gnome/report-gnome.scm | 3 + .../report/report-system/report-system.scm | 1 + gnucash/report/report-system/report.scm | 1 + .../report/standard-reports/CMakeLists.txt | 1 + .../report/standard-reports/balsheet-pnl.scm | 1253 +++++++++++++++++ po/POTFILES.in | 1 + 6 files changed, 1260 insertions(+) create mode 100644 gnucash/report/standard-reports/balsheet-pnl.scm diff --git a/gnucash/report/report-gnome/report-gnome.scm b/gnucash/report/report-gnome/report-gnome.scm index 004db7d628..6d6748bc01 100644 --- a/gnucash/report/report-gnome/report-gnome.scm +++ b/gnucash/report/report-gnome/report-gnome.scm @@ -104,6 +104,8 @@ (gnc:make-menu gnc:menuname-budget (list gnc:menuname-reports))) (define utility-menu (gnc:make-menu gnc:menuname-utility (list gnc:menuname-reports))) + (define experimental-menu + (gnc:make-menu gnc:menuname-experimental (list gnc:menuname-reports))) (define tax-menu (gnc:make-menu gnc:menuname-taxes (list gnc:menuname-reports))) (define business-menu @@ -123,6 +125,7 @@ (gnc-add-scm-extension asset-liability-menu) (gnc-add-scm-extension budget-menu) (gnc-add-scm-extension utility-menu) + (gnc-add-scm-extension experimental-menu) (gnc-add-scm-extension business-menu) ;; run report-hook danglers diff --git a/gnucash/report/report-system/report-system.scm b/gnucash/report/report-system/report-system.scm index 387135e512..de16b73fcd 100644 --- a/gnucash/report/report-system/report-system.scm +++ b/gnucash/report/report-system/report-system.scm @@ -131,6 +131,7 @@ (export gnc:menuname-budget) (export gnc:menuname-taxes) (export gnc:menuname-utility) +(export gnc:menuname-experimental) (export gnc:menuname-custom) (export gnc:menuname-business-reports) (export gnc:pagename-general) diff --git a/gnucash/report/report-system/report.scm b/gnucash/report/report-system/report.scm index b48acd828c..a0793ef549 100644 --- a/gnucash/report/report-system/report.scm +++ b/gnucash/report/report-system/report.scm @@ -63,6 +63,7 @@ (define gnc:menuname-budget (N_ "B_udget")) (define gnc:menuname-taxes (N_ "_Taxes")) (define gnc:menuname-utility (N_ "_Sample & Custom")) +(define gnc:menuname-experimental (N_ "_Experimental")) (define gnc:menuname-custom (N_ "_Custom")) (define gnc:pagename-general (N_ "General")) (define gnc:pagename-accounts (N_ "Accounts")) diff --git a/gnucash/report/standard-reports/CMakeLists.txt b/gnucash/report/standard-reports/CMakeLists.txt index 429e7a43fe..df87daf306 100644 --- a/gnucash/report/standard-reports/CMakeLists.txt +++ b/gnucash/report/standard-reports/CMakeLists.txt @@ -10,6 +10,7 @@ set (standard_reports_SCHEME_2 average-balance.scm balance-sheet.scm balance-forecast.scm + balsheet-pnl.scm budget-balance-sheet.scm budget-barchart.scm budget-flow.scm diff --git a/gnucash/report/standard-reports/balsheet-pnl.scm b/gnucash/report/standard-reports/balsheet-pnl.scm new file mode 100644 index 0000000000..7a331ee9e0 --- /dev/null +++ b/gnucash/report/standard-reports/balsheet-pnl.scm @@ -0,0 +1,1253 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; balsheet-pnl.scm: multi-column report. includes +;; balance-sheet and p&l reports. +;; +;; By Christopher Lam, 2018 +;; +;; Improved from balance-sheet.scm +;; +;; 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 +;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652 +;; Boston, MA 02110-1301, USA gnu@gnu.org +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-module (gnucash report standard-reports balsheet-pnl)) +(use-modules (gnucash utilities)) +(use-modules (gnucash gnc-module)) +(use-modules (gnucash gettext)) +(use-modules (srfi srfi-1)) + +(gnc:module-load "gnucash/report/report-system" 0) + +(define FOOTER-TEXT + (gnc:make-html-text + (_ "WARNING: Foreign currency conversions, and unrealized gains +calculations are not confirmed correct. This report may be modified +without notice. Bug reports are very welcome at +https://bugs.gnucash.org/"))) + +;; define all option's names and help text so that they are properly + +(define optname-startdate (N_ "Start Date")) +(define optname-enddate (N_ "End Date")) + +(define optname-period (N_ "Period duration")) +(define opthelp-period (N_ "Duration between time periods")) + +(define optname-dual-columns (N_ "Enable dual columns")) +(define opthelp-dual-columns (N_ "Selecting this option will enable double-column \ +reporting.")) + +(define optname-disable-amount-indent (N_ "Disable amount indenting")) +(define opthelp-disable-amount-indent (N_ "Selecting this option will disable amount indenting, and condense amounts into a single column.")) + +(define optname-options-summary (N_ "Add options summary")) +(define opthelp-options-summary (N_ "Add summary of options.")) + +(define optname-account-full-name (N_ "Account full name instead of indenting")) +(define opthelp-account-full-name (N_ "Selecting this option enables full account name instead, and disables indenting account names.")) + +(define optname-accounts (N_ "Accounts")) +(define opthelp-accounts (N_ "Report on these accounts, if display depth allows.")) + +(define optname-depth-limit (N_ "Levels of Subaccounts")) +(define opthelp-depth-limit (N_ "Maximum number of levels in the account tree displayed.")) + +(define optname-parent-balance-mode (N_ "Parent account amounts include children")) +(define opthelp-parent-balance-mode (N_ "If this option is enabled, subtotals are \ +displayed within parent amounts, and if parent has own amount, it is displayed on \ +the next row as a child account. If this option is disabled, subtotals are displayed \ +below parent and children groups.")) + +(define optname-show-zb-accts (N_ "Include accounts with zero total balances")) +(define opthelp-show-zb-accts (N_ "Include accounts with zero total (recursive) balances in this report.")) + +(define optname-omit-zb-bals (N_ "Omit zero balance figures")) +(define opthelp-omit-zb-bals (N_ "Show blank space in place of any zero balances which would be shown.")) + +(define optname-account-links (N_ "Display accounts as hyperlinks")) +(define opthelp-account-links (N_ "Shows each account in the table as a hyperlink to its register window.")) + +(define optname-amount-links (N_ "Display amounts as hyperlinks")) +(define opthelp-amount-links (N_ "Shows each amounts in the table as a hyperlink to a register or report.")) + +;; closing entries filter - for P&L report +(define pagename-entries "Closing Entries") +(define optname-closing-pattern (N_ "Closing Entries pattern")) +(define opthelp-closing-pattern (N_ "Any text in the Description column which identifies closing entries.")) +(define optname-closing-casing (N_ "Closing Entries pattern is case-sensitive")) +(define opthelp-closing-casing (N_ "Causes the Closing Entries Pattern match to be case-sensitive.")) +(define optname-closing-regexp (N_ "Closing Entries Pattern is regular expression")) +(define opthelp-closing-regexp (N_ "Causes the Closing Entries Pattern to be treated as a regular expression.")) + +;; section labels +(define optname-label-sections (N_ "Label sections")) +(define opthelp-label-sections (N_ "Whether or not to include a label for sections.")) +(define optname-total-sections (N_ "Include totals")) +(define opthelp-total-sections (N_ "Whether or not to include a line indicating total amounts.")) + +;; commodities +(define pagename-commodities (N_ "Commodities")) +(define optname-include-chart (N_ "Enable chart")) +(define opthelp-include-chart (N_ "Enable link to chart")) + +(define optname-common-currency (N_ "Common Currency")) +(define opthelp-common-currency (N_ "Convert all amounts to a single currency.")) + +(define optname-report-commodity (N_ "Report's currency")) + +(define optname-price-source (N_ "Price Source")) + +(define optname-show-foreign (N_ "Show original currency amount")) +(define opthelp-show-foreign (N_ "Also show original currency amounts")) + +(define optname-include-overall-period (N_ "If more than 1 period column, include overall period?")) +(define opthelp-include-overall-period (N_ "If several profit & loss period columns are shown, \ +also show overall period profit & loss.")) + +(define optname-show-rates (N_ "Show Exchange Rates")) +(define opthelp-show-rates (N_ "Show the exchange rates used.")) + +(define trep-uuid "2fe3b9833af044abb929a88d5a59620f") +(define networth-barchart-uuid "cbba1696c8c24744848062c7f1cf4a72") +(define pnl-barchart-uuid "80769921e87943adade887b9835a7685") + +(define periodlist + (list + (list #f + (cons 'delta #f) + (cons 'text (_ "Disabled")) + (cons 'tip (_ "Disabled"))) + + (list 'year + (cons 'delta YearDelta) + (cons 'text (_ "Year")) + (cons 'tip (_ "One year."))) + + (list 'halfyear + (cons 'delta HalfYearDelta) + (cons 'text (_ "Half Year")) + (cons 'tip (_ "Half Year."))) + + (list 'quarter + (cons 'delta QuarterDelta) + (cons 'text (_ "Quarter")) + (cons 'tip (_ "One Quarter."))) + + (list 'month + (cons 'delta MonthDelta) + (cons 'text (_ "Month")) + (cons 'tip (_ "One Month."))) + + (list 'twoweek + (cons 'delta TwoWeekDelta) + (cons 'text (_ "2Week")) + (cons 'tip (_ "Two Weeks."))) + + (list 'week + (cons 'delta WeekDelta) + (cons 'text (_ "Week")) + (cons 'tip (_ "One Week."))))) + +(define (keylist->vectorlist keylist) + (map + (lambda (item) + (vector + (car item) + (keylist-get-info keylist (car item) 'text) + (keylist-get-info keylist (car item) 'tip))) + keylist)) + +(define (keylist-get-info keylist key info) + (assq-ref (assq-ref keylist key) info)) + +;; options generator +(define (multicol-report-options-generator report-type) + (let* ((options (gnc:new-options)) + (book (gnc-get-current-book)) + (add-option + (lambda (new-option) + (gnc:register-option options new-option)))) + + ;; date at which to report balance + (gnc:options-add-date-interval! + options gnc:pagename-general optname-startdate optname-enddate "c") + + (add-option + (gnc:make-multichoice-callback-option + gnc:pagename-general optname-period + "c2" opthelp-period + #f + (keylist->vectorlist periodlist) + #f + (lambda (x) + (gnc-option-db-set-option-selectable-by-name + options + gnc:pagename-general optname-disable-amount-indent + (not x)) + (gnc-option-db-set-option-selectable-by-name + options + gnc:pagename-general optname-dual-columns + (not x)) + (gnc-option-db-set-option-selectable-by-name + options + gnc:pagename-general + (case report-type + ((balsheet) optname-startdate) + ((pnl) optname-include-overall-period)) + x)))) + + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-general optname-disable-amount-indent + "c3" opthelp-disable-amount-indent #f)) + + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-general optname-include-chart + "d" opthelp-include-chart #f)) + + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-general optname-dual-columns + "c4" opthelp-dual-columns #t)) + + (add-option + (gnc:make-multichoice-option + gnc:pagename-general optname-options-summary + "d" opthelp-options-summary + 'never + (list (vector 'always + (_ "Always") + (_ "Always display summary.")) + (vector 'never + (_ "Never") + (_ "Disable report summary."))))) + + ;; accounts to work on + (add-option + (gnc:make-account-list-option + gnc:pagename-accounts optname-accounts + "a" + opthelp-accounts + (lambda () + (gnc:filter-accountlist-type + (list ACCT-TYPE-BANK ACCT-TYPE-CASH ACCT-TYPE-CREDIT + ACCT-TYPE-ASSET ACCT-TYPE-LIABILITY + ACCT-TYPE-STOCK ACCT-TYPE-MUTUAL ACCT-TYPE-CURRENCY + ACCT-TYPE-PAYABLE ACCT-TYPE-RECEIVABLE + ACCT-TYPE-EQUITY ACCT-TYPE-INCOME ACCT-TYPE-EXPENSE + ACCT-TYPE-TRADING) + (gnc-account-get-descendants-sorted (gnc-get-current-root-account)))) + #f #t)) + + ;; the depth-limit option is not well debugged; it may be better + ;; to disable it altogether + (gnc:options-add-account-levels! + options gnc:pagename-accounts optname-depth-limit + "b" opthelp-depth-limit 'all) + + ;; all about currencies + (add-option + (gnc:make-complex-boolean-option + pagename-commodities optname-common-currency + "b" opthelp-common-currency #f #f + (lambda (x) + (for-each + (lambda (optname) + (gnc-option-db-set-option-selectable-by-name + options pagename-commodities optname x)) + (list optname-report-commodity + optname-show-rates + optname-show-foreign + optname-price-source))))) + + (gnc:options-add-currency! + options pagename-commodities + optname-report-commodity "c") + + (gnc:options-add-price-source! + options pagename-commodities + optname-price-source "d" 'pricedb-nearest) + + (add-option + (gnc:make-simple-boolean-option + pagename-commodities optname-show-foreign + "e" opthelp-show-foreign #t)) + + (add-option + (gnc:make-simple-boolean-option + pagename-commodities optname-show-rates + "f" opthelp-show-rates #t)) + + ;; what to show for zero-balance accounts + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-display optname-show-zb-accts + "a" opthelp-show-zb-accts #t)) + + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-display optname-omit-zb-bals + "b" opthelp-omit-zb-bals #f)) + + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-display optname-parent-balance-mode + "c" opthelp-parent-balance-mode #t)) + + ;; some detailed formatting options + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-display optname-account-links + "e" opthelp-account-links #t)) + + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-display optname-amount-links + "e5" opthelp-amount-links #t)) + + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-display optname-account-full-name + "f" opthelp-account-full-name #f)) + + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-display optname-label-sections "g" opthelp-label-sections #t)) + + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-display optname-total-sections "h" opthelp-total-sections #t)) + + (when (eq? report-type 'pnl) + ;; include overall period column? + (add-option + (gnc:make-simple-boolean-option + gnc:pagename-general optname-include-overall-period + "e" opthelp-include-overall-period #f)) + + ;; closing entry match criteria + (add-option + (gnc:make-string-option + pagename-entries optname-closing-pattern + "a" opthelp-closing-pattern (_ "Closing Entries"))) + + (add-option + (gnc:make-simple-boolean-option + pagename-entries optname-closing-casing + "b" opthelp-closing-casing #f)) + + (add-option + (gnc:make-simple-boolean-option + pagename-entries optname-closing-regexp + "c" opthelp-closing-regexp #f))) + + (gnc:options-set-default-section options gnc:pagename-general) + + options)) + +(define* (add-multicolumn-acct-table + table title accountlist maxindent get-cell-monetary-fn cols-data #:key + (omit-zb-bals? #f) + (show-zb-accts? #t) + (disable-account-indent? #f) + (disable-amount-indent? #f) + (show-orig-cur? #t) + (show-title? #t) + (show-accounts? #t) + (show-total? #t) + (depth-limit #f) + (negate-amounts? #f) + (recursive-bals? #f) + (account-anchor? #t) + (get-col-header-fn #f) + (convert-curr-fn #f) + (get-cell-anchor-fn #f)) + + ;; this function will add a 2D grid into the html-table + ;; the data cells are generated from (get-cell-monetary-fn account col-datum) + ;; the data cells may request an alternative (eg. original currency) monetary + ;; horizontal labels are generated from calling (get-col-header-fn col-datum) + ;; vertical labels are the account list. it can have multilevel subtotals. + + ;; the following are compulsory arguments: + ;; table - an existing html-table object + ;; title - string as the first row + ;; accountlist - list of accounts + ;; maxindent - maximum account depth + ;; cols-data - list of data to be passed as parameter to the following helper functions + ;; get-cell-monetary-fn - a lambda (account cols-data) which produces a gnc-monetary or #f (eg price conversion impossible) + + ;; the following are optional: + ;; omit-zb-bals? - a boolean to omit "$0.00" amounts + ;; show-zb-accts? - a boolean to omit whole account lines where all amounts are $0.00 (eg closed accts) + ;; show-title? - a bool to show/hide individual sections: title row + ;; show-accounts? - a bool to show/hide individual sections: accounts list and data columns + ;; show-total? - a bool to show/hide individual sections: accounts total + ;; disable-account-indent? - a boolean to disable narrow-cell indenting, and render account full-name instead + ;; disable-amount-indent? - a bool to disable amount indenting (only for single data column reports) + ;; negate-amounts? - a boolean to negate amounts. useful for e.g. income-type accounts. + ;; depth-limit - (untested) accounts whose levels exceed this depth limit are not shown + ;; recursive-bals? - a boolean to confirm recursive-balances enabled (parent-accounts show balances) or + ;; disabled (multilevel subtotals after each parent+children) + ;; account-anchor? - a boolean to enable/disable account link to account + ;; amount-anchor? - a boolean to enable/disable amount link to report/register + ;; get-col-header-fn - a lambda (accounts cols-data) to produce html-object - this is optional + ;; convert-curr-fn - a lambda (monetary cols-data) which produces a gnc-monetary or #f - optional + ;; show-orig-cur? - a boolean to enable/disable original currency after convert-curr-fn + ;; get-cell-anchor-fn - a lambda (account cols-data) which produces a url string - optional + + (define num-columns (length cols-data)) + + (define amount-indenting? (and (not disable-amount-indent?) (= num-columns 1))) + + (define (make-list-thunk n thunk) + (let loop ((result '()) (n n)) + (if (zero? n) result + (loop (cons (thunk) result) (1- n))))) + + (define (make-narrow-cell) + (let ((narrow (gnc:make-html-table-cell/markup "text-cell" #f))) + (gnc:html-table-cell-set-style! + narrow "text-cell" + 'attribute '("style" "width:1px")) + narrow)) + + (define (add-indented-row indent label label-markup amount-indent rest) + (when (or (not depth-limit) (<= indent depth-limit)) + (gnc:html-table-append-row! + table + (append (if disable-account-indent? + '() (make-list-thunk indent make-narrow-cell)) + (list (if label-markup + (gnc:make-html-table-cell/size/markup + 1 (if disable-account-indent? 1 (- maxindent indent)) + label-markup label) + (gnc:make-html-table-cell/size + 1 (if disable-account-indent? 1 (- maxindent indent)) + label))) + (gnc:html-make-empty-cells + (if amount-indenting? (1- amount-indent) 0)) + rest + (gnc:html-make-empty-cells + (if amount-indenting? (- maxindent amount-indent) 0)))))) + + (define (monetary+ . monetaries) + ;; usage: (monetary+ monetary...) + ;; inputs: list of gnc-monetary (e.g. USD 10, USD 25, GBP 5, GBP 8) + ;; outputs: list of gnc-monetary (e.g. USD 35, GBP 13), or '() + (let ((coll (gnc:make-commodity-collector))) + (for-each + (lambda (monetary) + (if monetary + (coll 'add + (gnc:gnc-monetary-commodity monetary) + (let ((amount (gnc:gnc-monetary-amount monetary))) + (if negate-amounts? (- amount) amount))))) + monetaries) + (coll 'format gnc:make-gnc-monetary #f))) + + (define (list-of-monetary->html-text monetaries col-datum anchor) + ;; inputs: + ;; monetaries: list of gnc-monetary (or #f, or html-text object) + ;; col-datum: col-datum to help convert monetary currency + ;; anchor: url string for monetaries (or #f) (all have same anchor) + ;; + ;; outputs: html-text object + (let ((text (gnc:make-html-text))) + (for-each + (lambda (monetary) + (let ((converted (and show-orig-cur? + convert-curr-fn + (convert-curr-fn monetary col-datum)))) + (if (not (and omit-zb-bals? + (gnc:gnc-monetary? monetary) + (zero? (gnc:gnc-monetary-amount monetary)))) + (gnc:html-text-append! text + (if converted + (gnc:html-markup-i + (gnc:html-markup "small" monetary " ")) + "") + (if anchor + (gnc:html-markup-anchor + anchor (or converted monetary)) + (or converted monetary)) + (gnc:html-markup-br))))) + monetaries) + text)) + + (define (account->depth acc) + (cond ((vector? acc) 0) + (else (gnc-account-get-current-depth acc)))) + + (define (account->descendants acc) + (cond ((vector? acc) '()) + (else (gnc-account-get-descendants acc)))) + + (define (render-account account total?) + ;; input: account-name + ;; outputs: string or html-markup-anchor object + (let* ((virtual? (vector? account)) + (acct-name (cond + (virtual? (vector-ref account 0)) + (disable-account-indent? (gnc-account-get-full-name account)) + (else (xaccAccountGetName account)))) + (acct-label (if (and (not virtual?) total?) + (string-append (_ "Total For ") acct-name) + acct-name)) + (acct-url (and account-anchor? + (not total?) + (not virtual?) + (not (xaccAccountGetPlaceholder account)) + (gnc:account-anchor-text account)))) + (gnc:make-html-text + (if acct-url + (gnc:html-markup-anchor acct-url acct-label) + acct-label)))) + + (define (add-whole-line contents) + (gnc:html-table-append-row! + table (gnc:make-html-table-cell/size + 1 (+ 1 (if disable-account-indent? 0 maxindent) num-columns) + contents))) + + (define (account-and-descendants account) + (cons account (filter (lambda (acc) (member acc accountlist)) + (account->descendants account)))) + + (define (sum-accounts-at-col accounts datum convert?) + ;; outputs: list of gnc-monetary + + (let loop ((accounts accounts) + (result '())) + (cond + ((null? accounts) + (apply monetary+ result)) + (else + (let* ((acc (car accounts)) + (monetary (if (vector? acc) + ((vector-ref acc 1) datum) + (get-cell-monetary-fn acc datum))) + (amt (or (and convert? convert-curr-fn + (not (list? monetary)) + (convert-curr-fn monetary datum)) + monetary))) + (loop (cdr accounts) + (if (list? amt) + (append amt result) + (cons amt result)))))))) + + (define (is-not-zero? accts) + ;; this function tests whether accounts (with descendants) of all + ;; columns are zero. + (not (every zero? (concatenate + (map + (lambda (col-datum) + (map gnc:gnc-monetary-amount + (sum-accounts-at-col accts col-datum #f))) + cols-data))))) + + (define* (add-recursive-subtotal lvl lvl-acct #:key account-style-normal?) + (if (or show-zb-accts? + (is-not-zero? (account-and-descendants lvl-acct))) + (add-indented-row lvl + (render-account lvl-acct (not account-style-normal?)) + (if account-style-normal? + "text-cell" + "total-label-cell") + (- maxindent lvl) + (map + (lambda (col-datum) + (gnc:make-html-table-cell/markup + "total-number-cell" + (list-of-monetary->html-text + (sum-accounts-at-col (account-and-descendants lvl-acct) + col-datum + #t) + col-datum + #f))) + cols-data)))) + + (define* (add-account-row lvl-curr curr #:key + (override-show-zb-accts? #f) + (account-indent 0)) + (if (or show-zb-accts? + override-show-zb-accts? + (is-not-zero? (list curr))) + (add-indented-row lvl-curr + (render-account curr #f) + "text-cell" + (- maxindent lvl-curr account-indent) + (map + (lambda (col-datum) + (gnc:make-html-table-cell/markup + "number-cell" + (list-of-monetary->html-text + (sum-accounts-at-col + (list curr) + col-datum + (not show-orig-cur?)) + col-datum + (and get-cell-anchor-fn + (not (vector? curr)) + (get-cell-anchor-fn curr col-datum))))) + cols-data)))) + + ;; header ASSET/LIABILITY etc + (if show-title? + (add-indented-row 0 + title + "total-label-cell" + maxindent + (if get-col-header-fn + (map + (lambda (col-datum) + (get-col-header-fn accountlist col-datum)) + cols-data) + (gnc:html-make-empty-cells num-columns)))) + + (let loop ((accounts (if show-accounts? accountlist '()))) + (if (pair? accounts) + (let* ((curr (car accounts)) + (rest (cdr accounts)) + (next (and (pair? rest) (car rest))) + (lvl-curr (account->depth curr)) + (lvl-next (if next (account->depth next) 0)) + (curr-descendants-list (filter + (lambda (acc) (member acc accountlist)) + (account->descendants curr))) + (recursive-parent-acct? (and recursive-bals? + (pair? curr-descendants-list))) + (multilevel-parent-acct? (and (not recursive-bals?) + (pair? curr-descendants-list)))) + + (if recursive-parent-acct? + (begin + (add-recursive-subtotal lvl-curr curr #:account-style-normal? #t) + (if (is-not-zero? (list curr)) + (add-account-row (1+ lvl-curr) curr #:override-show-zb-accts? #t))) + (add-account-row lvl-curr curr + #:account-indent (if multilevel-parent-acct? 1 0) + #:override-show-zb-accts? multilevel-parent-acct?)) + + (if (and (not recursive-bals?) + (> lvl-curr lvl-next)) + (let multilevel-loop ((lvl (1- lvl-curr)) + (lvl-acct (gnc-account-get-parent curr))) + (unless (or (zero? lvl) + (not (member lvl-acct accountlist)) + (< lvl lvl-next)) + (add-recursive-subtotal lvl lvl-acct) + (multilevel-loop (1- lvl) + (gnc-account-get-parent lvl-acct))))) + (loop rest)))) + + (if show-total? + (add-indented-row 0 + (string-append (_ "Total For ") title) + "total-label-cell" + maxindent + (map + (lambda (col-datum) + (let ((total-cell (gnc:make-html-table-cell/markup + "total-number-cell" + (list-of-monetary->html-text + (sum-accounts-at-col accountlist + col-datum + #t) + col-datum + #f)))) + (gnc:html-table-cell-set-style! + total-cell "total-number-cell" + 'attribute '("style" "border-top-style:solid; border-top-width: 1px; border-bottom-style:double")) + total-cell)) + cols-data))) + (add-whole-line #f)) + +(define (monetary-less . monetaries) + ;; syntax: (monetary-less mon0 mon1 mon2 ...) + ;; equiv: (- mon0 mon1 mon2 ...) + ;; this works only if all monetaries have the same commodity + (let ((res (gnc:make-commodity-collector))) + (res 'add (gnc:gnc-monetary-commodity (car monetaries)) + (gnc:gnc-monetary-amount (car monetaries))) + (for-each + (lambda (mon) + (res 'add (gnc:gnc-monetary-commodity mon) (- (gnc:gnc-monetary-amount mon)))) + (cdr monetaries)) + (let ((reslist (res 'format gnc:make-gnc-monetary #f))) + (if (null? (cdr reslist)) + (car reslist) + (gnc:error "monetary-less: 1 commodity only" monetaries))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; multicol-report-renderer + ;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (multicol-report-renderer report-obj report-type) + (define (get-option pagename optname) + (gnc:option-value + (gnc:lookup-option + (gnc:report-options report-obj) pagename optname))) + + (gnc:report-starting (get-option gnc:pagename-general gnc:optname-reportname)) + + ;; get all options values + (let* ((report-title (get-option gnc:pagename-general gnc:optname-reportname)) + (startdate (gnc:date-option-absolute-time + (get-option gnc:pagename-general + optname-startdate))) + (enddate (gnc:date-option-absolute-time + (get-option gnc:pagename-general + optname-enddate))) + (disable-account-indent? (get-option gnc:pagename-display + optname-account-full-name)) + (incr (let ((period (get-option gnc:pagename-general optname-period))) + (and period + (keylist-get-info periodlist period 'delta)))) + (disable-amount-indent? (and (not incr) + (get-option gnc:pagename-general + optname-disable-amount-indent))) + (enable-dual-columns? (and (not incr) + (get-option gnc:pagename-general + optname-dual-columns))) + (accounts (get-option gnc:pagename-accounts + optname-accounts)) + (depth-limit (let ((limit (get-option gnc:pagename-accounts + optname-depth-limit))) + (and (not (eq? limit 'all)) limit))) + (show-zb-accts? (get-option gnc:pagename-display + optname-show-zb-accts)) + (omit-zb-bals? (get-option gnc:pagename-display + optname-omit-zb-bals)) + (recursive-bals? (get-option gnc:pagename-display + optname-parent-balance-mode)) + (label-sections? (get-option gnc:pagename-display + optname-label-sections)) + (total-sections? (get-option gnc:pagename-display + optname-total-sections)) + (use-links? (get-option gnc:pagename-display + optname-account-links)) + (use-amount-links? (get-option gnc:pagename-display + optname-amount-links)) + (include-chart? (get-option gnc:pagename-general optname-include-chart)) + (common-currency (and + (get-option pagename-commodities optname-common-currency) + (get-option pagename-commodities optname-report-commodity))) + (has-price? (lambda (commodity) + ;; the following tests whether an amount in + ;; commodity can be converted to + ;; common-currency. if conversion successful, + ;; it will be a non-zero value. note if we use + ;; API gnc-pricedb-has-prices, we're only + ;; querying the pricedb. if we use + ;; gnc-pricedb-convert-balance-latest-price, we + ;; can potentially use an intermediate + ;; currency. + (not (zero? (gnc-pricedb-convert-balance-latest-price + (gnc-pricedb-get-db (gnc-get-current-book)) + (gnc-commodity-get-fraction commodity) + commodity + common-currency))))) + (price-source (and common-currency + (get-option pagename-commodities optname-price-source))) + (report-dates (map (if (eq? report-type 'balsheet) + gnc:time64-end-day-time + gnc:time64-start-day-time) + (if incr + (gnc:make-date-list startdate enddate incr) + (if (eq? report-type 'balsheet) + (list enddate) + (list startdate enddate))))) + (accounts-balances (map + (lambda (acc) + (cons acc + (gnc:account-get-balances-at-dates + acc report-dates))) + accounts)) + (exchange-fn (and common-currency + (gnc:case-exchange-time-fn + price-source common-currency + (map xaccAccountGetCommodity accounts) enddate + #f #f))) + (convert-curr-fn (lambda (monetary col-idx) + (and common-currency + (not (gnc-commodity-equal + (gnc:gnc-monetary-commodity monetary) + common-currency)) + (has-price? (gnc:gnc-monetary-commodity monetary)) + (let* ((date (case price-source + ((pricedb-latest) (current-time)) + (else + (list-ref report-dates + (case report-type + ((balsheet) col-idx) + ((pnl) (1+ col-idx)))))))) + (exchange-fn monetary common-currency date))))) + ;; the following function generates an gnc:html-text object + ;; to dump exchange rate for a particular column. From the + ;; accountlist given, obtain commodities, and convert 1 unit + ;; currency into report-currency. If cannot convert due to + ;; missing price, say so. + (get-exchange-rates-fn + (lambda (accounts col-idx) + (let ((commodities (delete + common-currency + (delete-duplicates + (map xaccAccountGetCommodity accounts) + gnc-commodity-equal) + gnc-commodity-equal)) + (cell (gnc:make-html-text))) + (for-each + (lambda (commodity) + (let ((orig-monetary (gnc:make-gnc-monetary commodity 1))) + (if (has-price? commodity) + (let ((conv-monetary (convert-curr-fn orig-monetary col-idx))) + (gnc:html-text-append! + cell + (format #f "~a ~a" + (gnc:monetary->string orig-monetary) + (gnc:monetary->string conv-monetary)))) + (gnc:html-text-append! + cell + (string-append + (format #f "~a ~a " + (gnc:monetary->string orig-monetary) + (gnc-commodity-get-nice-symbol common-currency)) + (_ "missing"))))) + (gnc:html-text-append! cell (gnc:html-markup-br))) + commodities) + (gnc:make-html-table-cell/markup "number-cell" cell)))) + + ;; decompose the account list + (show-foreign? (get-option pagename-commodities optname-show-foreign)) + (show-rates? (get-option pagename-commodities optname-show-rates)) + (split-up-accounts (gnc:decompose-accountlist accounts)) + (asset-accounts + (assoc-ref split-up-accounts ACCT-TYPE-ASSET)) + (liability-accounts + (assoc-ref split-up-accounts ACCT-TYPE-LIABILITY)) + (income-accounts + (assoc-ref split-up-accounts ACCT-TYPE-INCOME)) + (expense-accounts + (assoc-ref split-up-accounts ACCT-TYPE-EXPENSE)) + (equity-accounts + (assoc-ref split-up-accounts ACCT-TYPE-EQUITY)) + (trading-accounts + (assoc-ref split-up-accounts ACCT-TYPE-TRADING)) + (doc (gnc:make-html-document)) + (multicol-table-left (gnc:make-html-table)) + (multicol-table-right (if enable-dual-columns? + (gnc:make-html-table) + multicol-table-left)) + (maxindent (gnc-account-get-tree-depth (gnc-get-current-root-account)))) + + (gnc:html-document-set-title! + doc (with-output-to-string + (lambda () + (display report-title) + (display " ") + (when (or incr (eq? report-type 'pnl)) + (display (qof-print-date startdate)) + (display (_ " to "))) + (display (qof-print-date enddate))))) + + (if (eq? (get-option gnc:pagename-general optname-options-summary) 'always) + (gnc:html-document-add-object! + doc (gnc:html-render-options-changed (gnc:report-options report-obj)))) + + (cond + ((null? accounts) + (gnc:html-document-add-object! + doc + (gnc:html-make-no-account-warning + report-title (gnc:report-id report-obj)))) + + ((eq? report-type 'balsheet) + (let* ((get-cell-monetary-fn + (lambda (account col-idx) + (let ((account-balance-list (assoc account accounts-balances))) + (and account-balance-list + (list-ref account-balance-list (1+ col-idx)))))) + (get-cell-anchor-fn + (lambda (account col-idx) + (let* ((splits (xaccAccountGetSplitList account)) + (split-date (compose xaccTransGetDate xaccSplitGetParent)) + (date (list-ref report-dates col-idx)) + (valid-split? (lambda (s) (< (split-date s) date))) + (valid-splits (filter valid-split? splits))) + (and (pair? valid-splits) + (gnc:split-anchor-text (last valid-splits)))))) + (asset-liability-balances + (apply map gnc:monetaries-add + (map cdr (filter + (lambda (acc-balances) + (member (car acc-balances) + (append asset-accounts liability-accounts))) + accounts-balances)))) + (income-expense-balances + (map gnc:commodity-collector-get-negated + (apply map gnc:monetaries-add + (map cdr + (filter + (lambda (acc-balances) + (member (car acc-balances) + (append income-accounts expense-accounts))) + accounts-balances))))) + (monetaries->exchanged + (lambda (monetaries target-currency price-source date) + (let ((exchange-fn (gnc:case-exchange-fn + price-source target-currency date))) + (apply gnc:monetary+ + (map + (lambda (mon) + (exchange-fn mon target-currency)) + (monetaries 'format gnc:make-gnc-monetary #f)))))) + (unrealized-gain-fn + (lambda (col-idx) + (and common-currency + (let* ((date (case price-source + ((pricedb-latest) (current-time)) + (else (list-ref report-dates col-idx)))) + (asset-liability-balance + (list-ref asset-liability-balances col-idx)) + (latest (monetaries->exchanged + asset-liability-balance + common-currency price-source date)) + (avg-cost (monetaries->exchanged + asset-liability-balance + common-currency 'average-cost date))) + (gnc:monetary+ latest (gnc:monetary-neg avg-cost)))))) + (retained-earnings-fn + (lambda (col-idx) + (let* ((date (case price-source + ((pricedb-latest) (current-time)) + (else (list-ref report-dates col-idx)))) + (income-expense-balance + (list-ref income-expense-balances col-idx))) + (map + gnc:monetary-neg + (if (and common-currency + (every has-price? + (map xaccAccountGetCommodity + (append income-accounts + expense-accounts)))) + (monetaries->exchanged income-expense-balance + common-currency price-source date) + (income-expense-balance 'format gnc:make-gnc-monetary #f)))))) + (chart (and include-chart? + (gnc:make-report-anchor + networth-barchart-uuid report-obj + (list (list "General" "Start Date" (cons 'absolute startdate)) + (list "General" "End Date" (cons 'absolute enddate)) + (list "General" "Report's currency" + (or common-currency + (gnc-default-report-currency))) + (list "General" "Price Source" + (or price-source 'pricedb-nearest)) + (list "Accounts" "Accounts" + (append asset-accounts liability-accounts)))))) + (get-col-header-fn (lambda (accounts col-idx) + (let* ((date (list-ref report-dates col-idx)) + (header (qof-print-date date)) + (cell (gnc:make-html-table-cell/markup + "total-label-cell" header))) + (gnc:html-table-cell-set-style! + cell "total-label-cell" + 'attribute '("style" "text-align:right")) + cell))) + (add-to-table (lambda* (table title accounts #:key + (get-col-header-fn #f) + (show-accounts? #t) + (show-total? #t) + (show-title? #t) + (force-total? #f) + (convert-fn #f) + (negate-amounts? #f)) + (add-multicolumn-acct-table + table title accounts + maxindent get-cell-monetary-fn + (iota (length report-dates)) + #:omit-zb-bals? omit-zb-bals? + #:show-zb-accts? show-zb-accts? + #:disable-account-indent? disable-account-indent? + #:negate-amounts? negate-amounts? + #:disable-amount-indent? disable-amount-indent? + #:depth-limit (if get-col-header-fn 0 depth-limit) + #:show-orig-cur? (and (not convert-fn) show-foreign?) + #:show-title? (and show-title? label-sections?) + #:show-accounts? show-accounts? + #:show-total? (or (and total-sections? show-total?) + force-total?) + #:recursive-bals? recursive-bals? + #:account-anchor? use-links? + #:convert-curr-fn (and common-currency + (or convert-fn convert-curr-fn)) + #:get-col-header-fn get-col-header-fn + #:get-cell-anchor-fn (and use-amount-links? + get-cell-anchor-fn) + )))) + + (when incr + (add-to-table multicol-table-left (_ "Date") '() + #:get-col-header-fn get-col-header-fn + #:show-accounts? #f + #:show-total? #f) + (if enable-dual-columns? + (add-to-table multicol-table-right (_ "Date") '() + #:get-col-header-fn get-col-header-fn + #:show-accounts? #f + #:show-total? #f))) + + (unless (null? asset-accounts) + (add-to-table multicol-table-left (_ "Asset") asset-accounts)) + + (unless (null? liability-accounts) + (add-to-table multicol-table-right (_ "Liability") liability-accounts + #:negate-amounts? #t)) + + (add-to-table + multicol-table-right (_ "Equity") + (append equity-accounts + (list + (vector "Unrealized Gains" + unrealized-gain-fn) + (vector "Retained Earnings" + retained-earnings-fn))) + #:negate-amounts? #t) + + (if (and common-currency show-rates?) + (add-to-table multicol-table-right (_ "Exchange Rates") + (append asset-accounts liability-accounts) + #:get-col-header-fn get-exchange-rates-fn + #:show-accounts? #f + #:show-total? #f)) + + (if include-chart? + (gnc:html-document-add-object! + doc + (gnc:make-html-text + (gnc:html-markup-anchor chart "Barchart")))))) + + ((eq? report-type 'pnl) + (let* ((closing-str (get-option pagename-entries optname-closing-pattern)) + (closing-cased (get-option pagename-entries optname-closing-casing)) + (closing-regexp (get-option pagename-entries optname-closing-regexp)) + (include-overall-period? (get-option gnc:pagename-general + optname-include-overall-period)) + (col-idx->datepair (lambda (idx) + (if (eq? idx 'overall-period) + (cons (car report-dates) (last report-dates)) + (cons (list-ref report-dates idx) + (gnc:time64-end-day-time + (decdate + (list-ref report-dates (1+ idx)) + DayDelta)))))) + (col-idx->monetarypair (lambda (balancelist idx) + (if (eq? idx 'overall-period) + (cons (car balancelist) (last balancelist)) + (cons (list-ref balancelist idx) + (list-ref balancelist (1+ idx)))))) + (closing-entries (let ((query (qof-query-create-for-splits))) + (qof-query-set-book query (gnc-get-current-book)) + (xaccQueryAddAccountMatch + query (append income-accounts expense-accounts) + QOF-GUID-MATCH-ANY QOF-QUERY-AND) + (if (and closing-str (not (string-null? closing-str))) + (xaccQueryAddDescriptionMatch + query closing-str closing-cased closing-regexp + QOF-COMPARE-CONTAINS QOF-QUERY-AND)) + (xaccQueryAddClosingTransMatch query #t QOF-QUERY-OR) + (let ((splits (qof-query-run query))) + (qof-query-destroy query) + splits))) + ;; this function will query the above closing-entries for + ;; splits within the date range, and produce the total + ;; amount for these closing entries + (closing-adjustment + (lambda (account col-idx) + (define datepair (col-idx->datepair col-idx)) + (define (include-split? split) + (and (equal? (xaccSplitGetAccount split) account) + (<= (car datepair) + (xaccTransGetDate (xaccSplitGetParent split)) + (cdr datepair)))) + (let ((account-closing-splits (filter include-split? closing-entries))) + (gnc:make-gnc-monetary + (xaccAccountGetCommodity account) + (apply + (map xaccSplitGetAmount account-closing-splits)))))) + (get-cell-monetary-fn + (lambda (account col-idx) + (let ((account-balance-list (assoc account accounts-balances))) + (and account-balance-list + (let ((monetarypair (col-idx->monetarypair + (cdr account-balance-list) + col-idx))) + (monetary-less + (cdr monetarypair) + (car monetarypair) + (closing-adjustment account col-idx))))))) + (get-cell-anchor-fn (lambda (account col-idx) + (define datepair (col-idx->datepair col-idx)) + (gnc:make-report-anchor + trep-uuid report-obj + (list + (list "General" "Start Date" + (cons 'absolute (car datepair))) + (list "General" "End Date" + (cons 'absolute (cdr datepair))) + (list "Display" "Amount" 'double) + (list "Accounts" "Accounts" + (list account)))))) + (chart (and include-chart? + (gnc:make-report-anchor + pnl-barchart-uuid report-obj + (list (list "General" "Start Date" + (cons 'absolute startdate)) + (list "General" "End Date" + (cons 'absolute enddate)) + (list "General" "Report's currency" + (or common-currency + (gnc-default-report-currency))) + (list "General" "Price Source" + (or price-source 'pricedb-nearest)) + (list "Accounts" "Accounts" + (append income-accounts expense-accounts)))))) + (get-col-header-fn + (lambda (accounts col-idx) + (let* ((datepair (col-idx->datepair col-idx)) + (header (gnc:make-html-text + (qof-print-date (car datepair)) + (gnc:html-markup-br) + (_ " to ") + (qof-print-date (cdr datepair)))) + (cell (gnc:make-html-table-cell/markup + "total-label-cell" header))) + (gnc:html-table-cell-set-style! + cell "total-label-cell" + 'attribute '("style" "text-align:right")) + cell))) + (add-to-table (lambda* (table title accounts #:key + (get-col-header-fn #f) + (show-accounts? #t) + (show-total? #t) + (force-total? #f) + (negate-amounts? #f)) + (add-multicolumn-acct-table + table title accounts + maxindent get-cell-monetary-fn + (append + (iota (1- (length report-dates))) + (if (and include-overall-period? + (> (length report-dates) 2)) + '(overall-period) + '())) + #:omit-zb-bals? omit-zb-bals? + #:show-zb-accts? show-zb-accts? + #:disable-account-indent? disable-account-indent? + #:negate-amounts? negate-amounts? + #:disable-amount-indent? disable-amount-indent? + #:depth-limit (if get-col-header-fn 0 depth-limit) + #:show-orig-cur? show-foreign? + #:show-title? label-sections? + #:show-accounts? show-accounts? + #:show-total? (or (and total-sections? show-total?) + force-total?) + #:recursive-bals? recursive-bals? + #:account-anchor? use-links? + #:convert-curr-fn (and common-currency convert-curr-fn) + #:get-col-header-fn get-col-header-fn + #:get-cell-anchor-fn (and use-amount-links? + get-cell-anchor-fn))))) + + (when incr + (add-to-table multicol-table-left (_ "Period") '() + #:get-col-header-fn get-col-header-fn + #:show-accounts? #f + #:show-total? #f) + (if enable-dual-columns? + (add-to-table multicol-table-right (_ "Period") '() + #:get-col-header-fn get-col-header-fn + #:show-accounts? #f + #:show-total? #f))) + + (unless (null? income-accounts) + (add-to-table multicol-table-left (_ "Income") income-accounts + #:negate-amounts? #t)) + + (unless (null? expense-accounts) + (add-to-table multicol-table-right (_ "Expense") expense-accounts)) + + (unless (or (null? income-accounts) + (null? expense-accounts)) + (add-to-table multicol-table-left (_ "Net Income") + (append income-accounts expense-accounts) + #:show-accounts? #f + #:negate-amounts? #t + #:force-total? #t)) + + (if (and common-currency show-rates?) + (add-to-table multicol-table-left (_ "Exchange Rates") + (append income-accounts expense-accounts) + #:get-col-header-fn get-exchange-rates-fn + #:show-accounts? #f + #:show-total? #f)) + + (if include-chart? + (gnc:html-document-add-object! + doc + (gnc:make-html-text + (gnc:html-markup-anchor chart "Barchart"))))))) + + (let ((multicol-table (if enable-dual-columns? + (gnc:make-html-table) + multicol-table-left))) + (when enable-dual-columns? + (gnc:html-table-append-row! multicol-table + (list multicol-table-left multicol-table-right))) + (gnc:html-document-add-object! + doc multicol-table)) + + (gnc:html-document-add-object! + doc FOOTER-TEXT) + + (gnc:report-finished) + ;; (gnc:html-document-set-style-text! + ;; doc " table, td{ border-width: 1px; border-style:solid; border-color: lightgray; border-collapse: collapse}") + doc)) + +(define balsheet-reportname (_ "Balance Sheet (Multicolumn)")) +(define pnl-reportname (_ "Income Statement (Multicolumn)")) + +(gnc:define-report + 'version 1 + 'name balsheet-reportname + 'report-guid "065d5d5a77ba11e8b31e83ada73c5eea" + 'menu-path (list gnc:menuname-experimental) + 'options-generator (lambda () (multicol-report-options-generator 'balsheet)) + 'renderer (lambda (rpt) (multicol-report-renderer rpt 'balsheet))) + +(gnc:define-report + 'version 1 + 'name pnl-reportname + 'report-guid "0e94fd0277ba11e8825d43e27232c9d4" + 'menu-path (list gnc:menuname-experimental) + 'options-generator (lambda () (multicol-report-options-generator 'pnl)) + 'renderer (lambda (rpt) (multicol-report-renderer rpt 'pnl))) + +;; END diff --git a/po/POTFILES.in b/po/POTFILES.in index a4cabf7165..a8d79d06b1 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -469,6 +469,7 @@ gnucash/report/standard-reports/advanced-portfolio.scm gnucash/report/standard-reports/average-balance.scm gnucash/report/standard-reports/balance-forecast.scm gnucash/report/standard-reports/balance-sheet.scm +gnucash/report/standard-reports/balsheet-pnl.scm gnucash/report/standard-reports/budget-balance-sheet.scm gnucash/report/standard-reports/budget-barchart.scm gnucash/report/standard-reports/budget-flow.scm