Welcome to the CHICKEN Scheme pasting service

Testing gnucash report added by sjamaan on Thu Oct 11 13:41:35 2018

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; category-barchart.scm: shows barchart of income/expense categories
;;  
;; By Christian Stimming 
;;
;; Tweaked by Peter Bex  to mix expenses and
;; liabilities so you can get an overview of monthly fixed costs.
;;
;; 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
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; depends must be outside module scope -- and should eventually go away.
(define-module (gnucash report fixed-costs))
(use-modules (gnucash report report-system report-collectors))
(use-modules (gnucash report report-system collectors))
(use-modules (srfi srfi-1))
(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
(use-modules (ice-9 regex))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))

(use-modules (gnucash printf))

(gnc:module-load "gnucash/report/report-system" 0)

;; included since Bug726449
(use-modules (ice-9 regex)) ;; for regexp-substitute/global, used by jpqplot
(load-from-path "html-jqplot") ;; for jqplot-escape-string

;; The menu statusbar tips.
(define menutip-fixed-costs
  (N_ "Shows a barchart with the Expenses + Liabilities interval \
developing over time, giving an overview of the total monthly (fixed) costs"))

;; The names here are used 1. for internal identification, 2. as
;; tab labels, 3. as default for the 'Report name' option which
;; in turn is used for the printed report title.
(define reportname-fixed-costs (N_ "Fixed costs Over Time"))

;; Option names
(define optname-from-date (N_ "Start Date"))
(define optname-to-date (N_ "End Date"))
(define optname-stepsize (N_ "Step Size"))
(define optname-report-currency (N_ "Report's currency"))
(define optname-price-source (N_ "Price Source"))

(define optname-accounts (N_ "Accounts"))
(define optname-levels (N_ "Show Accounts until level"))

(define optname-fullname (N_ "Show long account names"))
(define optname-stacked (N_ "Use Stacked Bars"))
(define optname-slices (N_ "Maximum Bars"))
(define optname-plot-width (N_ "Plot Width"))
(define optname-plot-height (N_ "Plot Height"))
(define optname-sort-method (N_ "Sort Method"))

(define optname-averaging (N_ "Show Average"))
(define opthelp-averaging (N_ "Select whether the amounts should be shown over the full time period or rather as the average e.g. per month."))

(define (options-generator account-types reverse-balance? do-intervals?)
  (let* ((options (gnc:new-options)) 
         (add-option 
          (lambda (new-option)
            (gnc:register-option options new-option))))

    ;; save off the reverse-balance option
    (add-option
     (gnc:make-internal-option "__report" "reverse-balance?" reverse-balance?))

    ;; General tab
    (gnc:options-add-date-interval!
     options gnc:pagename-general
     optname-from-date optname-to-date "a")

    (gnc:options-add-interval-choice! 
     options gnc:pagename-general optname-stepsize "b" 'MonthDelta)

    (gnc:options-add-currency! 
     options gnc:pagename-general optname-report-currency "c")

    (gnc:options-add-price-source! 
     options gnc:pagename-general
     optname-price-source "d" 'weighted-average)

    (if do-intervals?
        (add-option
         (gnc:make-multichoice-option
          gnc:pagename-general optname-averaging
          "e" opthelp-averaging
          'None
          (list (vector 'None
                        (N_ "No Averaging")
                        (N_ "Just show the amounts, without any averaging."))
                (vector 'MonthDelta
                        (N_ "Monthly")
                        (N_ "Show the average monthly amount during the reporting period."))
                (vector 'WeekDelta
                        (N_ "Weekly")
                        (N_ "Show the average weekly amount during the reporting period."))
                (vector 'DayDelta
                        (N_ "Daily")
                        (N_ "Show the average daily amount during the reporting period."))
                )
          ))
        )


    ;; Accounts tab
    (add-option
     (gnc:make-account-list-option
      gnc:pagename-accounts optname-accounts
      "a"
      (N_ "Report on these accounts, if chosen account level allows.")
      (lambda ()
        (gnc:filter-accountlist-type 
         account-types
         (gnc-account-get-descendants-sorted (gnc-get-current-root-account))))
      (lambda (accounts)
        (list #t
              (gnc:filter-accountlist-type account-types accounts)))
      #t))
    
    (gnc:options-add-account-levels! 
     options gnc:pagename-accounts optname-levels "c" 
     (N_ "Show accounts to this depth and not further.") 
     10)

    ;; Display tab
    (add-option
     (gnc:make-simple-boolean-option
      gnc:pagename-display optname-fullname
      "a" (N_ "Show the full account name in legend?") #f))

    (add-option
     (gnc:make-simple-boolean-option
      gnc:pagename-display optname-stacked
      "b" 
      (N_ "Show barchart as stacked barchart?") 
      #t))

    (add-option
     (gnc:make-number-range-option
      gnc:pagename-display optname-slices
      "c" (N_ "Maximum number of bars in the chart.") 10
      2 24 0 1))

    (add-option
     (gnc:make-simple-boolean-option
      gnc:pagename-display
      (N_ "Show table")
      "d" (N_ "Display a table of the selected data.")
      #t))

    (gnc:options-add-plot-size! 
     options gnc:pagename-display 
     optname-plot-width optname-plot-height "e" 400 400)

    (gnc:options-add-sort-method! 
     options gnc:pagename-display
     optname-sort-method "f" 'amount)

    (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 .  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.

;; FIXME: the exchange rate should change every time interval, of
;; course, but right now we assume the very last exchange rate to be
;; constant over the whole report period. Note that this might get
;; *really* complicated.

(define (category-barchart-renderer report-obj reportname reportguid 
                                    account-types do-intervals?)
  ;; A helper functions for looking up option values.
  (define (get-option section name)
    (gnc:option-value 
     (gnc:lookup-option 
      (gnc:report-options report-obj) section name)))
  
  (gnc:report-starting reportname)
  (let ((to-date-tp (gnc:timepair-end-day-time 
                     (gnc:date-option-absolute-time
                      (get-option gnc:pagename-general 
                                  optname-to-date))))
        (from-date-tp (gnc:timepair-start-day-time 
                       (gnc:date-option-absolute-time
                        (get-option gnc:pagename-general 
                                    optname-from-date))))
        (interval (get-option gnc:pagename-general optname-stepsize))
        (report-currency (get-option gnc:pagename-general
                                     optname-report-currency))
        (price-source (get-option gnc:pagename-general
                                  optname-price-source))
        (report-title (get-option gnc:pagename-general 
                                  gnc:optname-reportname))
        (averaging-selection (if do-intervals?
                                 (get-option gnc:pagename-general
                                             optname-averaging)
                                 'None))

        (accounts (get-option gnc:pagename-accounts optname-accounts))
        (account-levels (get-option gnc:pagename-accounts optname-levels))
        
        (stacked? (get-option gnc:pagename-display optname-stacked))
        (show-fullname? (get-option gnc:pagename-display optname-fullname))
        (max-slices (inexact->exact
		     (get-option gnc:pagename-display optname-slices)))
        (height (get-option gnc:pagename-display optname-plot-height))
        (width (get-option gnc:pagename-display optname-plot-width))
	(sort-method (get-option gnc:pagename-display optname-sort-method))
	(reverse-balance? (get-option "__report" "reverse-balance?"))

        (show-table? (get-option gnc:pagename-display (N_ "Show table")))
        (document (gnc:make-html-document))
        (chart (gnc:make-html-barchart))
        (table (gnc:make-html-table))
        (topl-accounts (gnc:filter-accountlist-type 
                        account-types
                        (gnc-account-get-children-sorted
                         (gnc-get-current-root-account)))))
    
    ;; Returns true if the account a was selected in the account
    ;; selection option.
    (define (show-acct? a)
      (member a accounts))

    ;;(gnc:debug accounts)
    (if (not (null? accounts))
        
        ;; Define more helper variables.
        (let* ((commodity-list #f)
               (exchange-fn #f)
               (tree-depth (if (equal? account-levels 'all)
                               (gnc:get-current-account-tree-depth)
                               account-levels))
               (averaging-fraction-func (gnc:date-get-fraction-func averaging-selection))
               (interval-fraction-func (gnc:date-get-fraction-func interval))
               (averaging-multiplier
                 (if averaging-fraction-func
                     ;; Calculate the divisor of the amounts so that an
                     ;; average is shown
                     (let* ((start-frac-avg (averaging-fraction-func (gnc:timepair->secs from-date-tp)))
                             (end-frac-avg (averaging-fraction-func (+ 1 (gnc:timepair->secs to-date-tp))))
                             (diff-avg (- end-frac-avg start-frac-avg))
                             (start-frac-int (interval-fraction-func (gnc:timepair->secs from-date-tp)))
                             (end-frac-int (interval-fraction-func (+ 1 (gnc:timepair->secs to-date-tp))))
                             (diff-int (- end-frac-int start-frac-int))
                            )
                     ;; Extra sanity check to ensure a number smaller than 1
                     (if (> diff-avg diff-int)
                         (/ diff-int diff-avg)
                         1))
                     1))
               ;; If there is averaging, the report-title is extended
               ;; accordingly.
               (report-title
                 (case averaging-selection
                   ((MonthDelta) (string-append report-title " " (_ "Monthly Average")))
                   ((WeekDelta) (string-append report-title " " (_ "Weekly Average")))
                   ((DayDelta) (string-append report-title " " (_ "Daily Average")))
                   (else report-title)))
               ;; This is the list of date intervals to calculate.
               (dates-list (if do-intervals?
                               (gnc:make-date-interval-list
                                (gnc:timepair-start-day-time from-date-tp) 
                                (gnc:timepair-end-day-time to-date-tp)
                                (gnc:deltasym-to-delta interval))
                               (gnc:make-date-list
                                (gnc:timepair-end-day-time from-date-tp) 
                                (gnc:timepair-end-day-time to-date-tp)
                                (gnc:deltasym-to-delta interval))))
               ;; Here the date strings for the x-axis labels are
               ;; created.
               (date-string-list
                (map (lambda (date-list-item)
                       (gnc-print-date
                        (if do-intervals?
                            (car date-list-item)
                            date-list-item)))
                     dates-list))
               (other-anchor "")
               (all-data '()))
          
          ;; Converts a commodity-collector into one single double
          ;; number, depending on the report's currency and the
          ;; exchange-fn calculated above. Returns a double, multiplied
          ;; by the averaging-multiplies (smaller than one; multiplication
          ;; instead of division to avoid division-by-zero issues) in case
          ;; the user wants to see the amounts averaged over some value.
          (define (collector->double c date)
            ;; Future improvement: Let the user choose which kind of
            ;; currency combining she want to be done.
	    (if (not (gnc:timepair? date))
		(throw 'wrong))
            (*
              (gnc-numeric-to-double
              (gnc:gnc-monetary-amount
                (gnc:sum-collector-commodity
                c report-currency
                (lambda (a b) (exchange-fn a b date)))))
             averaging-multiplier))

	  (define (count-accounts current-depth accts)
	    (if (< current-depth tree-depth)
		(let ((sum 0))
		  (for-each
		   (lambda (a)
		     (set! sum (+ sum (+ 1 (count-accounts (+ 1 current-depth)
							   (gnc-account-get-children a))))))
		   accts)
		  sum)
		(length (filter show-acct? accts))))

          ;; Calculates all account's balances. Returns a list of pairs:
          ;; ( ), like '((Earnings (10.0 11.2))
          ;; (Gifts (12.3 14.5))), where each element of 
          ;; is the balance corresponding to one element in
          ;; .
          ;;
          ;; If current-depth >= tree-depth, then the balances are
          ;; calculated *with* subaccount's balances. Else only the
          ;; current account is regarded. Note: All accounts in accts
          ;; and all their subaccounts are processed, but a balances is
          ;; calculated and returned *only* for those accounts where
          ;; show-acct? is true. This is necessary because otherwise we
          ;; would forget an account that is selected but not its
          ;; parent.
	  (define (apply-sign account x)
	    (if (reverse-balance? account) (- x) x))
          (define (calculate-report accounts progress-range)
	    (let* ((the-acount-destination-alist (account-destination-alist accounts
									    account-types
									    tree-depth))
		   (account-reformat
		    (if do-intervals?
			(lambda (account result)
			  (map (lambda (collector datepair)
				 (let ((date (second datepair)))
				   (apply-sign account (collector->double collector date))))
			       result dates-list))
			(lambda (account result)
			  (let ((commodity-collector (gnc:make-commodity-collector)))
			    (collector-end (fold (lambda (next date list-collector)
						   (commodity-collector 'merge next #f)
						   (collector-add list-collector
								  (apply-sign account
									      (collector->double commodity-collector
												 date))))
						 (collector-into-list)
						 result dates-list))))))

		   (the-work (category-by-account-report-work do-intervals?
				dates-list the-acount-destination-alist
				(lambda (account date)
				  (make-gnc-collector-collector))
				account-reformat))
		   (the-report (category-by-account-report-do-work the-work progress-range)))
	      the-report))

          ;; The percentage done numbers here are a hack so that
          ;; something gets displayed. On my system the
          ;; gnc:case-exchange-time-fn takes about 20% of the time
          ;; building up a list of prices for later use. Either this
          ;; routine needs to send progress reports, or the price
          ;; lookup should be distributed and done when actually
          ;; needed so as to amortize the cpu time properly.
	  (gnc:report-percent-done 1)
	  (set! commodity-list (gnc:accounts-get-commodities 
                                (append 
                                 (gnc:acccounts-get-all-subaccounts accounts)
                                 accounts)
                                report-currency))
	  (set! exchange-fn (gnc:case-exchange-time-fn 
                             price-source report-currency 
                             commodity-list to-date-tp
			     5 15))

          ;; Sort the account list according to the account code field.
          (set! all-data (sort
                          (filter (lambda (l)
                                    (not (= 0.0 (apply + (cadr l)))))
                                  (calculate-report accounts (cons 0 90)))
			  (cond
			   ((eq? sort-method 'acct-code)
			    (lambda (a b) 
			      (string (apply + (cadr a))
				 (apply + (cadr b))))))))
          ;; Or rather sort by total amount?
          ;;(< (apply + (cadr a)) 
          ;;   (apply + (cadr b))))))
          ;; Other sort criteria: max. amount, standard deviation of amount,
          ;; min. amount; ascending, descending. FIXME: Add user options to
          ;; choose sorting.
          
          
          ;;(gnc:warn "all-data" all-data)

          ;; Proceed if the data is non-zeros
          (if 
           (and (not (null? all-data))
                (gnc:not-all-zeros (map cadr all-data)))
           (begin 
             ;; Set chart title, subtitle etc.
             (gnc:html-barchart-set-title! chart report-title)
             (gnc:html-barchart-set-subtitle!
              chart (sprintf #f
                             (if do-intervals?
                                 (_ "%s to %s")
                                 (_ "Balances %s to %s"))
                             (jqplot-escape-string (gnc-print-date from-date-tp))
                             (jqplot-escape-string (gnc-print-date to-date-tp))))
             (gnc:html-barchart-set-width! chart width)
             (gnc:html-barchart-set-height! chart height)
             
             ;; row labels etc.
             (gnc:html-barchart-set-row-labels! chart date-string-list)
             ;; FIXME: axis labels are not yet supported by
             ;; libguppitank.
             (gnc:html-barchart-set-y-axis-label!
              chart (gnc-commodity-get-mnemonic report-currency))
             (gnc:html-barchart-set-row-labels-rotated?! chart #t)
             (gnc:html-barchart-set-stacked?! chart stacked?)
             ;; If this is a stacked barchart, then reverse the legend.
	     ;; Doesn't do what you'd expect. - DRH
	     ;; It does work, but needs Guppi 0.40.4. - cstim
             (gnc:html-barchart-set-legend-reversed?! chart stacked?)
             
             ;; If we have too many categories, we sum them into a new
             ;; 'other' category and add a link to a new report with just
             ;; those accounts.
             (if (> (length all-data) max-slices)
                 (let* ((start (take all-data (- max-slices 1)))
                        (finish (drop all-data (- max-slices 1)))
                        (other-sum (map 
                                    (lambda (l) (apply + l))
                                    (apply zip (map cadr finish)))))
                   (set! all-data
                         (append start
                                 (list (list (_ "Other") other-sum))))
                   (let* ((options (gnc:make-report-options reportguid))
                          (id #f))
                     ;; now copy all the options
                     (gnc:options-copy-values 
                      (gnc:report-options report-obj) options)
                     ;; and set the destination accounts
                     (gnc:option-set-value
                      (gnc:lookup-option options gnc:pagename-accounts 
                                         optname-accounts)
                      (map car finish))
                     ;; Set the URL to point to this report.
                     (set! id (gnc:make-report reportguid options))
                     (set! other-anchor (gnc:report-anchor-text id)))))
             
             
             ;; This adds the data. Note the apply-zip stuff: This
             ;; transposes the data, i.e. swaps rows and columns. Pretty
             ;; cool, eh? Courtesy of dave_p.
	     (gnc:report-percent-done 92)
             (if (not (null? all-data))
                 (gnc:html-barchart-set-data! 
                  chart 
                  (apply zip (map cadr all-data))))
             
             ;; Labels and colors
	     (gnc:report-percent-done 94)
             (gnc:html-barchart-set-col-labels!
              chart (map (lambda (pair)
                           (if (string? (car pair))
                               (car pair)
                               ((if show-fullname?
                                    gnc-account-get-full-name
                                    xaccAccountGetName) (car pair))))
                         all-data))
             (gnc:html-barchart-set-col-colors! 
              chart
              (gnc:assign-colors (length all-data)))
             
             ;; set the URLs; the slices are links to other reports
	     (gnc:report-percent-done 96)
             (let 
                 ((urls
                   (map 
                    (lambda (pair)
                      (if 
                       (string? (car pair))
                       other-anchor
                       (let* ((acct (car pair))
                              (subaccts 
                               (gnc-account-get-children acct)))
                         (if (null? subaccts)
                             ;; if leaf-account, make this an anchor
                             ;; to the register.
                             (gnc:account-anchor-text acct)
                             ;; if non-leaf account, make this a link
                             ;; to another report which is run on the
                             ;; immediate subaccounts of this account
                             ;; (and including this account).
                             (gnc:make-report-anchor
                              reportguid
                              report-obj
                              (list
                               (list gnc:pagename-accounts optname-accounts
                                     (cons acct subaccts))
                               (list gnc:pagename-accounts optname-levels
                                     (+ 1 tree-depth))
                               (list gnc:pagename-general 
                                     gnc:optname-reportname
                                     ((if show-fullname?
                                          gnc-account-get-full-name
                                          xaccAccountGetName) acct))))))))
                    all-data)))
               (gnc:html-barchart-set-button-1-bar-urls! 
                chart (append urls urls))
               ;; The legend urls do the same thing.
               (gnc:html-barchart-set-button-1-legend-urls! 
                chart (append urls urls)))
             
	     (gnc:report-percent-done 98)
             (gnc:html-document-add-object! document chart)
             (if show-table?
                 (begin
                   (gnc:html-table-append-column! table date-string-list)

                   (letrec
                       ((addcol
                         (lambda (col)
                           (if (not (null? col))
                               (begin
                                 (gnc:html-table-append-column!
                                  table (car col))
                                 (addcol (cdr col))
                                 )
                               ))
                         ))
                     (addcol (map cadr all-data))
                     )

                   (gnc:html-table-set-col-headers!
                    table
                    (append
                     (list (_ "Date"))
                     (map (lambda (pair)
                           (if (string? (car pair))
                               (car pair)
                               ((if show-fullname?
                                    gnc-account-get-full-name
                                    xaccAccountGetName) (car pair))))
                          all-data)
                     (if (> (gnc:html-table-num-columns table) 2)
                         (list (_ "Grand Total"))
                         '()
                         )
                     ))

                   (if (> (gnc:html-table-num-columns table) 2)
                       (letrec
                           ((sumtot
                             (lambda (row)
                               (if (null? row)
                                   '()
                                   (cons (sumrow (car row)) (sumtot (cdr row)))
                                   )
                               )
                             )
                            (sumrow
                             (lambda (row)
                               (if (not (null? row))
                                   (+ (car row) (sumrow (cdr row)))
                                   0
                                   )
                               )
                             ))
                         (gnc:html-table-append-column!
                          table
                          (sumtot (apply zip (map cadr all-data)))
                          )
                         )
                       )
                       ;; set numeric columns to align right
                   (for-each
                    (lambda (col)
                      (gnc:html-table-set-col-style!
                       table col "td"
                       'attribute (list "class" "number-cell")))
                    '(1 2 3 4 5 6 7 8 9 10 11 12 13 14))
                   (gnc:html-document-add-object! document table)
                   ) ;; begin if
                 )
             )

           ;; else if empty data
           (gnc:html-document-add-object!
            document
            (gnc:html-make-empty-data-warning
	     report-title (gnc:report-id report-obj)))))
        
	;; else 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))

;; Export reports

(export category-barchart-income-uuid category-barchart-expense-uuid
	category-barchart-asset-uuid category-barchart-liability-uuid)

(define category-barchart-fixed-costs-uuid "a04b4524cd7c4b3899571286f3974ff3")

(let ((account-types (list ACCT-TYPE-EXPENSE
                           ACCT-TYPE-LIABILITY
                           ACCT-TYPE-PAYABLE ACCT-TYPE-CREDIT
                           ACCT-TYPE-CREDITLINE)))
  (gnc:define-report
   'version 1
   'name reportname-fixed-costs
   'report-guid category-barchart-fixed-costs-uuid
   'menu-path (list gnc:menuname-income-expense)
   'menu-name (N_ "Fixed monthly costs")
   'menu-tip menutip-fixed-costs
   'options-generator
   (lambda ()
     (options-generator account-types (lambda (x) #f) #t))
   'renderer
   (lambda (report-obj)
     (category-barchart-renderer report-obj 
                                 reportname-fixed-costs
                                 category-barchart-fixed-costs-uuid
                                 account-types
                                 #t))))

Your annotation:

Enter a new annotation:

Your nick:
The title of your paste:
Your paste (mandatory) :
Which egg provides `hash-table-ref'?
Visually impaired? Let me spell it for you (wav file) download WAV