IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

2001-05-03 Christian Stimming <stimming@tuhh.de>

Browse Source 
* src/scm/report/account-summary.scm: fix bug.

	* src/scm/html-document.scm: added handler for scatter plots.

	* src/scm/report/price-scatter.scm: Added file. This eventually
	should show prices over time. ATM it demonstrates scatter plots in
	a meaningless report.

	* src/scm/html-scatter.scm: Added file. Provides scatter plots for
	reports.

	* src/scm/options.scm (gnc:color->hex-string): added function.


git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@4109 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas 2001-05-03 08:47:26 +00:00
parent 677b4196a7
commit 1385b1890e
10 changed files with 435 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
ChangeLog
View File

@ -1,3 +1,18 @@
2001-05-03 Christian Stimming <stimming@tuhh.de>
* src/scm/report/account-summary.scm: fix bug.
* src/scm/html-document.scm: added handler for scatter plots.
* src/scm/report/price-scatter.scm: Added file. This eventually
should show prices over time. ATM it demonstrates scatter plots in
a meaningless report.
* src/scm/html-scatter.scm: Added file. Provides scatter plots for
reports.
* src/scm/options.scm (gnc:color->hex-string): added function.
2001-05-03 Robert Graham Merkel <rgmerk@mira.net>
* src/scm/report/transaction-report.scm: fix bug with secondary

1
src/scm/Makefile.am
View File

@ -27,6 +27,7 @@ gnc_regular_scm_files = \
html-barchart.scm \
html-document.scm \
html-piechart.scm \
html-scatter.scm \
html-style-info.scm \
html-style-sheet.scm \
html-text.scm \

3
src/scm/html-document.scm
View File

@ -363,6 +363,9 @@
((gnc:html-piechart? obj)
(set! o (gnc:make-html-object-internal
gnc:html-piechart-render obj)))
((gnc:html-scatter? obj)
(set! o (gnc:make-html-object-internal
gnc:html-scatter-render obj)))
((gnc:html-object? obj)
(set! o obj))

224
src/scm/html-scatter.scm Normal file
View File

@ -0,0 +1,224 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-scatter.scm : generate HTML programmatically, with support
;; for simple style elements.
;; Copyright 2001 Christian Stimming <stimming@tuhh.de>
;;
;; Adapted from html-barchart.scm which is
;; Copyright 2000 Bill Gribble <grib@gnumatic.com>
;;
;; 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
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(gnc:support "html-scatter.scm")
(define <html-scatter>
(make-record-type "<html-scatter>"
'(width height title subtitle
x-axis-label y-axis-label
;; a list of x-y-value lists.
data
;; Valid marker names are:
;; "none", "circle", "diamond", "cross", "x",
;; "square", "asterisk", "filled circle",
;; "filled square", "filled diamond"
;; The full list can be found in
;; guppi3/src/libguppiplot/guppi-marker.c in
;; guppi_marker_info_array[]
marker
;; The color of the marker. Should be a rgba
;; value as a hex string, as returned by
;; gnc:color-option->hex-string
markercolor
)))
(define gnc:html-scatter?
(record-predicate <html-scatter>))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-scatter> class
;; generate the <object> form for a guppi scatter plot.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:make-html-scatter-internal
(record-constructor <html-scatter>))
(define (gnc:make-html-scatter)
(gnc:make-html-scatter-internal -1 -1 #f #f #f #f '() #f #f))
(define gnc:html-scatter-width
(record-accessor <html-scatter> 'width))
(define gnc:html-scatter-set-width!
(record-modifier <html-scatter> 'width))
(define gnc:html-scatter-height
(record-accessor <html-scatter> 'height))
(define gnc:html-scatter-set-height!
(record-modifier <html-scatter> 'height))
(define gnc:html-scatter-title
(record-accessor <html-scatter> 'title))
(define gnc:html-scatter-set-title!
(record-modifier <html-scatter> 'title))
(define gnc:html-scatter-subtitle
(record-accessor <html-scatter> 'subtitle))
(define gnc:html-scatter-set-subtitle!
(record-modifier <html-scatter> 'subtitle))
(define gnc:html-scatter-x-axis-label
(record-accessor <html-scatter> 'x-axis-label))
(define gnc:html-scatter-set-x-axis-label!
(record-modifier <html-scatter> 'x-axis-label))
(define gnc:html-scatter-y-axis-label
(record-accessor <html-scatter> 'y-axis-label))
(define gnc:html-scatter-set-y-axis-label!
(record-modifier <html-scatter> 'y-axis-label))
(define gnc:html-scatter-data
(record-accessor <html-scatter> 'data))
(define gnc:html-scatter-set-data!
(record-modifier <html-scatter> 'data))
(define gnc:html-scatter-marker
(record-accessor <html-scatter> 'marker))
(define gnc:html-scatter-set-marker!
(record-modifier <html-scatter> 'marker))
(define gnc:html-scatter-markercolor
(record-accessor <html-scatter> 'markercolor))
(define gnc:html-scatter-set-markercolor!
(record-modifier <html-scatter> 'markercolor))
(define (gnc:html-scatter-add-datapoint! scatter newpoint)
(if (and (list? newpoint)
(not (null? newpoint)))
(gnc:html-scatter-set-data!
scatter
(cons newpoint (gnc:html-scatter-data scatter)))))
;; The Renderer
(define (gnc:html-scatter-render scatter doc)
(define (ensure-numeric elt)
(cond ((number? elt)
elt)
((string? elt)
(with-input-from-string elt
(lambda ()
(let ((n (read)))
(if (number? n) n 0.0)))))
((gnc:gnc-numeric? elt)
(gnc:numeric-to-double elt))
(#t
0.0)))
(define (catenate-escaped-strings nlist)
(if (not (list? nlist))
""
(with-output-to-string
(lambda ()
(for-each
(lambda (s)
(let ((escaped
(regexp-substitute/global
#f " "
(regexp-substitute/global
#f "\\\\" s
'pre "\\\\" 'post)
'pre "\\ " 'post)))
(display escaped)
(display " ")))
nlist)))))
(let* ((retval '())
(push (lambda (l) (set! retval (cons l retval))))
(title (gnc:html-scatter-title scatter))
(subtitle (gnc:html-scatter-subtitle scatter))
(x-label (gnc:html-scatter-x-axis-label scatter))
(y-label (gnc:html-scatter-y-axis-label scatter))
(data (gnc:html-scatter-data scatter))
(marker (gnc:html-scatter-marker scatter))
(markercolor (gnc:html-scatter-markercolor scatter)))
(if (and (list? data)
(not (null? data)))
(begin
(push "<object classid=\"gnc-guppi-scatter\" width=")
(push (gnc:html-scatter-width scatter))
(push " height=")
(push (gnc:html-scatter-height scatter))
(push ">\n")
(if title
(begin
(push " <param name=\"title\" value=\"")
(push title) (push "\">\n")))
(if subtitle
(begin
(push " <param name=\"subtitle\" value=\"")
(push subtitle) (push "\">\n")))
(if (and (string? x-label) (> (string-length x-label) 0))
(begin
(push " <param name=\"x_axis_label\" value=\"")
(push x-label)
(push "\">\n")))
(if (and (string? y-label) (> (string-length y-label) 0))
(begin
(push " <param name=\"y_axis_label\" value=\"")
(push y-label)
(push "\">\n")))
(if marker
(begin
(push " <param name=\"marker\" value=\"")
(push marker)
(push "\">\n")))
(if markercolor
(begin
(push " <param name=\"color\" value=\"")
(push (string-append "0x" markercolor))
(push "\">\n")))
(if (and data (list? data))
(let ((datasize (length data))
(x-data (map-in-order car data))
(y-data (map-in-order cadr data)))
(push " <param name=\"datasize\" value=\"")
(push datasize) (push "\">\n")
(push " <param name=\"x_data\" value=\"")
(for-each-in-order (lambda (x)
(push (ensure-numeric x))
(push " "))
x-data)
(push "\">\n")
(push " <param name=\"y_data\" value=\"")
(for-each-in-order (lambda (x)
(push (ensure-numeric x))
(push " "))
y-data)
(push "\">\n")))
(push "Unable to push bar chart\n")
(push "</object> &nbsp;\n"))
" ")
retval))

14
src/scm/options.scm
View File

@ -772,27 +772,33 @@
(list range use-alpha)
#f #f #f)))
(define (gnc:color->html color range)
(define (gnc:color->hex-string color range)
(define (html-value value)
(inexact->exact
(min 255.0
(truncate (* (/ 255.0 range) value)))))
(let ((red (car color))
(green (cadr color))
(blue (caddr color)))
(string-append
"#"
(number->string (html-value red) 16)
(number->string (html-value green) 16)
(number->string (html-value blue) 16))))
(define (gnc:color->html color range)
(string-append "#"
(gnc:color->hex-string color range)))
(define (gnc:color-option->html color-option)
(let ((color (gnc:option-value color-option))
(range (car (gnc:option-data color-option))))
(gnc:color->html color range)))
(define (gnc:color-option->hex-string color-option)
(let ((color (gnc:option-value color-option))
(range (car (gnc:option-data color-option))))
(gnc:color->hex-string color range)))
;; Create a new options database
(define (gnc:new-options)

1
src/scm/report-html.scm
View File

@ -32,6 +32,7 @@
(gnc:depend "html-table.scm")
(gnc:depend "html-piechart.scm")
(gnc:depend "html-barchart.scm")
(gnc:depend "html-scatter.scm")
(gnc:depend "html-style-info.scm")
(gnc:depend "html-style-sheet.scm")
(gnc:depend "html-utilities.scm")

1
src/scm/report/Makefile.am
View File

@ -12,6 +12,7 @@ gncscm_DATA = \
net-barchart.scm \
pnl.scm \
portfolio.scm \
price-scatter.scm \
register.scm \
report-list.scm \
stylesheet-fancy.scm \

6
src/scm/report/account-summary.scm
View File

@ -171,8 +171,10 @@
report-currency exchange-fn accounts)));;)
;; error condition: no accounts specified
(gnc:html-document-add-object! doc (gnc:html-make-no-account-warning))))
doc)
(gnc:html-document-add-object!
doc
(gnc:html-make-no-account-warning)))
doc))
(gnc:define-report
'version 1

175
src/scm/report/price-scatter.scm Normal file
View File

@ -0,0 +1,175 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; price-scatter.scm: A scatter plot report about some price.
;;
;; By Christian Stimming <stimming@tuhh.de>
;;
;; 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
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(gnc:support "report/price-scatter.scm")
(gnc:depend "report-html.scm")
(let ((optname-from-date (N_ "From"))
(optname-to-date (N_ "To"))
(optname-stepsize (N_ "Step Size"))
(optname-report-currency (N_ "Report's currency"))
(optname-accounts (N_ "Accounts"))
(optname-inc-exp (N_ "Show Income/Expense"))
(optname-show-profit (N_ "Show Net Profit"))
(optname-sep-bars (N_ "Show Asset & Liability bars"))
(optname-net-bars (N_ "Show Net Worth bars"))
(optname-marker (N_ "Marker"))
(optname-markercolor (N_ "Marker Color"))
(optname-plot-width (N_ "Plot Width"))
(optname-plot-height (N_ "Plot Height")))
(define (options-generator)
(let* ((options (gnc:new-options))
;; This is just a helper function for making options.
(add-option
(lambda (new-option)
(gnc:register-option options new-option))))
(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)
(add-option
(gnc:make-account-list-option
gnc:pagename-accounts optname-accounts
"c"
(N_ "Report on these accounts, if chosen account level allows.")
(lambda ()
(gnc:group-get-subaccounts (gnc:get-current-group)))
(lambda (accounts)
(list #t
accounts))
#t))
(gnc:options-add-currency!
options gnc:pagename-general optname-report-currency "d")
(gnc:options-add-plot-size!
options gnc:pagename-display
optname-plot-width optname-plot-height "c" 500 400)
; (add-option
; (gnc:make-multichoice-option
; gnc:pagename-display optname-marker
; "a"
; (N_ "Choose a marker")
; "cross"
; (list
; (vector "circle" "circle" "circle")
; (vector "cross" "cross" "cross")
; (vector "square" "square" "square")
; (vector "asterisk" "asterisk" "asterisk")
; (vector "filled circle" "filled circle" "filled circle")
; (vector "filled square" "filled square" "filled square"))))
; (add-option
; (gnc:make-color-option
; gnc:pagename-display optname-markercolor
; "b"
; (N_ "Color of the marker")
; (list #xb2 #x22 #x22 0)
; 255 #f))
(gnc:options-set-default-section options gnc:pagename-general)
options))
;;;;;;;;;;;;;;;;;;;;;;;;
;; The renderer function
(define (renderer report-obj)
;; This is a helper function for looking up option values.
(define (op-value section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(let* ((to-date-tp (gnc:timepair-end-day-time
(gnc:date-option-absolute-time
(op-value gnc:pagename-general
optname-to-date))))
(from-date-tp (gnc:timepair-start-day-time
(gnc:date-option-absolute-time
(op-value gnc:pagename-general
optname-from-date))))
(interval (op-value gnc:pagename-general optname-stepsize))
(accounts (op-value gnc:pagename-accounts optname-accounts))
(height (op-value gnc:pagename-display optname-plot-height))
(width (op-value gnc:pagename-display optname-plot-width))
;;(marker (op-value gnc:pagename-display optname-marker))
; (mcolor
; (gnc:color-option->hex-string
; (gnc:lookup-option (gnc:report-options report-obj)
; gnc:pagename-display optname-markercolor)))
(report-currency (op-value gnc:pagename-general
optname-report-currency))
(dates-list (gnc:make-date-list
(gnc:timepair-end-day-time from-date-tp)
(gnc:timepair-end-day-time to-date-tp)
(eval interval)))
(document (gnc:make-html-document))
(chart (gnc:make-html-scatter)))
(gnc:html-scatter-set-title!
chart (_ "Price Plot (Test)"))
(gnc:html-scatter-set-subtitle!
chart (sprintf #f
(_ "%s to %s")
(gnc:timepair-to-datestring from-date-tp)
(gnc:timepair-to-datestring to-date-tp)))
(gnc:html-scatter-set-width! chart width)
(gnc:html-scatter-set-height! chart height)
;;(warn marker mcolor)
;;(gnc:html-scatter-set-marker! chart marker)
;;(gnc:html-scatter-set-markercolor! chart mcolor)
(gnc:html-scatter-set-y-axis-label!
chart (gnc:commodity-get-mnemonic report-currency))
(gnc:html-scatter-set-data!
chart
'((1.0 1.0) (1.1 1.2) (1.2 1.4) (1.3 1.6)
(2.0 1.0) (2.1 1.2) (2.2 1.4) (2.3 1.6)))
(gnc:html-document-add-object! document chart)
document))
;; Here we define the actual report
(gnc:define-report
'version 1
'name (N_ "Price Scatter Plot (Test)")
;;'menu-path (list gnc:menuname-asset-liability)
'options-generator options-generator
'renderer renderer))

1
src/scm/report/report-list.scm
View File

@ -15,6 +15,7 @@
(gnc:depend "report/pnl.scm")
(gnc:depend "report/hello-world.scm")
(gnc:depend "report/portfolio.scm")
(gnc:depend "report/price-scatter.scm")
(gnc:depend "report/register.scm")
(gnc:depend "report/iframe-url.scm")
(gnc:depend "report/taxtxf.scm")