From 1385b1890eb314f9b2b700ece3be799bafa0f370 Mon Sep 17 00:00:00 2001 From: Dave Peticolas Date: Thu, 3 May 2001 08:47:26 +0000 Subject: [PATCH] 2001-05-03 Christian Stimming * 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 --- ChangeLog | 15 ++ src/scm/Makefile.am | 1 + src/scm/html-document.scm | 3 + src/scm/html-scatter.scm | 224 +++++++++++++++++++++++++++++ src/scm/options.scm | 14 +- src/scm/report-html.scm | 1 + src/scm/report/Makefile.am | 1 + src/scm/report/account-summary.scm | 6 +- src/scm/report/price-scatter.scm | 175 ++++++++++++++++++++++ src/scm/report/report-list.scm | 1 + 10 files changed, 435 insertions(+), 6 deletions(-) create mode 100644 src/scm/html-scatter.scm create mode 100644 src/scm/report/price-scatter.scm diff --git a/ChangeLog b/ChangeLog index 0d74be0b6a..8f9878363b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,18 @@ +2001-05-03 Christian Stimming + + * 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 * src/scm/report/transaction-report.scm: fix bug with secondary diff --git a/src/scm/Makefile.am b/src/scm/Makefile.am index 355ff157ed..1b7f3748fb 100644 --- a/src/scm/Makefile.am +++ b/src/scm/Makefile.am @@ -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 \ diff --git a/src/scm/html-document.scm b/src/scm/html-document.scm index b4e311ae12..2fd6a56135 100644 --- a/src/scm/html-document.scm +++ b/src/scm/html-document.scm @@ -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)) diff --git a/src/scm/html-scatter.scm b/src/scm/html-scatter.scm new file mode 100644 index 0000000000..36c186c898 --- /dev/null +++ b/src/scm/html-scatter.scm @@ -0,0 +1,224 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; html-scatter.scm : generate HTML programmatically, with support +;; for simple style elements. +;; Copyright 2001 Christian Stimming +;; +;; Adapted from html-barchart.scm which is +;; Copyright 2000 Bill Gribble +;; +;; 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 + (make-record-type "" + '(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 )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; class +;; generate the form for a guppi scatter plot. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define gnc:make-html-scatter-internal + (record-constructor )) + +(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 'width)) + +(define gnc:html-scatter-set-width! + (record-modifier 'width)) + +(define gnc:html-scatter-height + (record-accessor 'height)) + +(define gnc:html-scatter-set-height! + (record-modifier 'height)) + +(define gnc:html-scatter-title + (record-accessor 'title)) + +(define gnc:html-scatter-set-title! + (record-modifier 'title)) + +(define gnc:html-scatter-subtitle + (record-accessor 'subtitle)) + +(define gnc:html-scatter-set-subtitle! + (record-modifier 'subtitle)) + +(define gnc:html-scatter-x-axis-label + (record-accessor 'x-axis-label)) + +(define gnc:html-scatter-set-x-axis-label! + (record-modifier 'x-axis-label)) + +(define gnc:html-scatter-y-axis-label + (record-accessor 'y-axis-label)) + +(define gnc:html-scatter-set-y-axis-label! + (record-modifier 'y-axis-label)) + +(define gnc:html-scatter-data + (record-accessor 'data)) + +(define gnc:html-scatter-set-data! + (record-modifier 'data)) + +(define gnc:html-scatter-marker + (record-accessor 'marker)) + +(define gnc:html-scatter-set-marker! + (record-modifier 'marker)) + +(define gnc:html-scatter-markercolor + (record-accessor 'markercolor)) + +(define gnc:html-scatter-set-markercolor! + (record-modifier '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 "\n") + (if title + (begin + (push " \n"))) + (if subtitle + (begin + (push " \n"))) + (if (and (string? x-label) (> (string-length x-label) 0)) + (begin + (push " \n"))) + (if (and (string? y-label) (> (string-length y-label) 0)) + (begin + (push " \n"))) + (if marker + (begin + (push " \n"))) + (if markercolor + (begin + (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 " \n") + (push " \n") + (push " \n"))) + (push "Unable to push bar chart\n") + (push "  \n")) + " ") + retval)) diff --git a/src/scm/options.scm b/src/scm/options.scm index 8edc846025..319015c40e 100644 --- a/src/scm/options.scm +++ b/src/scm/options.scm @@ -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) diff --git a/src/scm/report-html.scm b/src/scm/report-html.scm index 0de2c751c7..6be321377e 100644 --- a/src/scm/report-html.scm +++ b/src/scm/report-html.scm @@ -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") diff --git a/src/scm/report/Makefile.am b/src/scm/report/Makefile.am index ede22a495f..7ca9f3f745 100644 --- a/src/scm/report/Makefile.am +++ b/src/scm/report/Makefile.am @@ -12,6 +12,7 @@ gncscm_DATA = \ net-barchart.scm \ pnl.scm \ portfolio.scm \ + price-scatter.scm \ register.scm \ report-list.scm \ stylesheet-fancy.scm \ diff --git a/src/scm/report/account-summary.scm b/src/scm/report/account-summary.scm index e4865d8f24..3c7a014483 100644 --- a/src/scm/report/account-summary.scm +++ b/src/scm/report/account-summary.scm @@ -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 diff --git a/src/scm/report/price-scatter.scm b/src/scm/report/price-scatter.scm new file mode 100644 index 0000000000..5c07f76288 --- /dev/null +++ b/src/scm/report/price-scatter.scm @@ -0,0 +1,175 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; price-scatter.scm: A scatter plot report about some price. +;; +;; By Christian Stimming +;; +;; 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)) + diff --git a/src/scm/report/report-list.scm b/src/scm/report/report-list.scm index e0072edd4e..7091c6c668 100644 --- a/src/scm/report/report-list.scm +++ b/src/scm/report/report-list.scm @@ -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")