r17685 - gnucash/trunk/src - Add line charts for reports
Christian Stimming
cstim at cvs.gnucash.org
Sat Nov 8 08:40:34 EST 2008
Author: cstim
Date: 2008-11-08 08:40:33 -0500 (Sat, 08 Nov 2008)
New Revision: 17685
Trac: http://svn.gnucash.org/trac/changeset/17685
Added:
gnucash/trunk/src/report/report-system/html-linechart.scm
Modified:
gnucash/trunk/src/gnome-utils/gnc-html-graph-gog.c
gnucash/trunk/src/report/report-system/Makefile.am
gnucash/trunk/src/report/report-system/html-document.scm
gnucash/trunk/src/report/report-system/report-system.scm
Log:
Add line charts for reports
The contributor writes:
I needed a line chart for a custom report and was surprised to find
that it is currently not supported by Gnucash. Line charts are
supported by the GOffice library, so I implemented line charts based
on the bar charts implementation (and added some new parameters for
markers and grid).
Patch by Sven Henkel <shenkel at gmail.com>.
Modified: gnucash/trunk/src/gnome-utils/gnc-html-graph-gog.c
===================================================================
--- gnucash/trunk/src/gnome-utils/gnc-html-graph-gog.c 2008-11-07 21:59:09 UTC (rev 17684)
+++ gnucash/trunk/src/gnome-utils/gnc-html-graph-gog.c 2008-11-08 13:40:33 UTC (rev 17685)
@@ -71,6 +71,7 @@
static int handle_piechart(gnc_html * html, GtkHTMLEmbedded * eb, gpointer d);
static int handle_barchart(gnc_html * html, GtkHTMLEmbedded * eb, gpointer d);
+static int handle_linechart(gnc_html * html, GtkHTMLEmbedded * eb, gpointer d);
static int handle_scatter(gnc_html * html, GtkHTMLEmbedded * eb, gpointer d);
#ifdef GTKHTML_USES_GTKPRINT
@@ -103,6 +104,7 @@
gnc_html_register_object_handler( "gnc-guppi-pie", handle_piechart );
gnc_html_register_object_handler( "gnc-guppi-bar", handle_barchart );
gnc_html_register_object_handler( "gnc-guppi-scatter", handle_scatter );
+ gnc_html_register_object_handler( "gnc-guppi-line", handle_linechart );
}
static double *
@@ -519,7 +521,167 @@
return TRUE;
}
+
+/**
+ * data_rows:int
+ * data_cols:int
+ * data:doubles[], data_rows*data_cols
+ * x_axis_label:string
+ * y_axis_label:string
+ * row_labels:string[]
+ * col_labels:string[]
+ * col_colors:string[]
+ * rotate_row_labels:boolean
+ * stacked:boolean
+ * markers:boolean
+ * major_grid:boolean
+ * minor_grid:boolean
+ **/
static gboolean
+handle_linechart(gnc_html * html, GtkHTMLEmbedded * eb, gpointer unused)
+{
+ GogObject *graph, *chart;
+ GogPlot *plot;
+ GogSeries *series;
+ GogStyle *style;
+ GOData *label_data, *slice_data;
+ int data_rows, data_cols;
+ double *data = NULL;
+ char **col_labels = NULL, **row_labels = NULL, **col_colors = NULL;
+ gboolean rotate_row_labels = FALSE;
+ gboolean stacked = FALSE;
+ gboolean markers = FALSE;
+ gboolean major_grid = FALSE;
+ gboolean minor_grid = FALSE;
+ char *line_type = "normal";
+
+ gtkhtml_pre_3_10_1_bug_workaround (eb);
+
+ // parse data from the text-ized params
+ // series => lines [gnc:cols]
+ // series-elements => segments [gnc:rows]
+ {
+ char *data_rows_str, *data_cols_str, *data_str, *col_labels_str, *row_labels_str;
+ char *col_colors_str, *rotate_row_labels_str = NULL, *stacked_str = NULL, *markers_str = NULL;
+ char *major_grid_str = NULL, *minor_grid_str = NULL;
+
+ data_rows_str = g_hash_table_lookup (eb->params, "data_rows");
+ data_cols_str = g_hash_table_lookup (eb->params, "data_cols");
+ data_str = g_hash_table_lookup (eb->params, "data" );
+ row_labels_str = g_hash_table_lookup (eb->params, "row_labels");
+ col_labels_str = g_hash_table_lookup (eb->params, "col_labels");
+ col_colors_str = g_hash_table_lookup (eb->params, "col_colors");
+ rotate_row_labels_str = g_hash_table_lookup (eb->params, "rotate_row_labels");
+ stacked_str = g_hash_table_lookup (eb->params, "stacked");
+ markers_str = g_hash_table_lookup (eb->params, "markers");
+ major_grid_str = g_hash_table_lookup (eb->params, "major_grid");
+ minor_grid_str = g_hash_table_lookup (eb->params, "minor_grid");
+
+ rotate_row_labels = (gboolean) atoi (rotate_row_labels_str);
+ stacked = (gboolean) atoi (stacked_str);
+ markers = (gboolean) atoi (markers_str);
+ major_grid = (gboolean) atoi (major_grid_str);
+ minor_grid = (gboolean) atoi (minor_grid_str);
+
+#if 0 // too strong at the moment.
+ g_return_val_if_fail (data_rows_str != NULL
+ && data_cols_str != NULL
+ && data_str != NULL
+ && col_labels_str != NULL
+ && row_labels_str != NULL
+ && col_colors_str != NULL, FALSE );
+#endif // 0
+
+ data_rows = atoi (data_rows_str);
+ data_cols = atoi (data_cols_str);
+ data = read_doubles (data_str, data_rows*data_cols);
+ row_labels = read_strings (row_labels_str, data_rows);
+ col_labels = read_strings (col_labels_str, data_cols);
+ col_colors = read_strings (col_colors_str, data_cols);
+ }
+
+ if (!create_basic_plot_elements("GogLinePlot", &graph, &chart, &plot)) {
+ return FALSE;
+ }
+ gog_object_add_by_name(chart, "Legend", NULL);
+
+ if ( stacked ) {
+ // when stacked, we want the lines on _top_ of eachother.
+ line_type = "stacked";
+ }
+
+ g_object_set (G_OBJECT (plot),
+ //"vary_style_by_element", TRUE,
+ "type", line_type,
+ "default-style-has-markers", markers,
+ NULL);
+ label_data = go_data_vector_str_new ((char const * const *)row_labels, data_rows, NULL);
+ {
+ // foreach row:
+ // series = row
+ GdkColor color;
+ int i;
+ for (i = 0; i < data_cols; i++) {
+ GError *err = NULL;
+
+ series = gog_plot_new_series (plot);
+ gog_object_set_name (GOG_OBJECT (series), col_labels[i], &err);
+ if (err != NULL)
+ {
+ g_warning("error setting name [%s] on series [%d]: [%s]",
+ col_labels[i], i, err->message);
+ }
+
+ g_object_ref (label_data);
+ gog_series_set_dim (series, 0, label_data, NULL);
+ go_data_emit_changed (GO_DATA (label_data));
+
+ slice_data = go_data_vector_val_new (data + (i*data_rows), data_rows, NULL);
+ gog_series_set_dim (series, 1, slice_data, NULL);
+ go_data_emit_changed (GO_DATA (slice_data));
+
+ style = gog_styled_object_get_style (GOG_STYLED_OBJECT (series));
+ style->fill.type = GOG_FILL_STYLE_PATTERN;
+ if (gdk_color_parse (col_colors[i], &color)) {
+ style->fill.auto_back = FALSE;
+ go_pattern_set_solid (&style->fill.pattern, GDK_TO_UINT (color));
+ } else {
+ g_warning("cannot parse color [%s]", col_colors[i]);
+ }
+ }
+ }
+
+ if (rotate_row_labels) {
+ GogObject *object = gog_object_get_child_by_role (
+ chart, gog_object_find_role_by_name (chart, "X-Axis"));
+ style = gog_styled_object_get_style (GOG_STYLED_OBJECT (object));
+ gog_style_set_text_angle (style, 90.0);
+ }
+
+ if (major_grid || minor_grid) {
+ GogObject *object;
+ gog_object_add_by_name(chart,"Grid", NULL);
+ object = gog_object_get_child_by_role (chart, gog_object_find_role_by_name (chart, "Y-Axis"));
+ if (major_grid)
+ gog_object_add_by_name (GOG_OBJECT (object),"MajorGrid", NULL);
+ if (minor_grid)
+ gog_object_add_by_name (GOG_OBJECT (object),"MinorGrid", NULL);
+ }
+
+ set_chart_titles_from_hash (chart, eb);
+ set_chart_axis_labels_from_hash (chart, eb);
+
+ // we need to do this twice for the linechart... :p
+ gog_object_update (GOG_OBJECT (graph));
+
+ add_pixbuf_graph_widget (eb, graph);
+
+ g_debug("linechart rendered.");
+ return TRUE;
+}
+
+
+static gboolean
handle_scatter(gnc_html * html, GtkHTMLEmbedded * eb, gpointer unused)
{
GogObject *graph, *chart;
Modified: gnucash/trunk/src/report/report-system/Makefile.am
===================================================================
--- gnucash/trunk/src/report/report-system/Makefile.am 2008-11-07 21:59:09 UTC (rev 17684)
+++ gnucash/trunk/src/report/report-system/Makefile.am 2008-11-08 13:40:33 UTC (rev 17685)
@@ -39,6 +39,7 @@
html-document.scm \
html-piechart.scm \
html-scatter.scm \
+ html-linechart.scm \
html-style-info.scm \
html-style-sheet.scm \
html-table.scm \
Modified: gnucash/trunk/src/report/report-system/html-document.scm
===================================================================
--- gnucash/trunk/src/report/report-system/html-document.scm 2008-11-07 21:59:09 UTC (rev 17684)
+++ gnucash/trunk/src/report/report-system/html-document.scm 2008-11-08 13:40:33 UTC (rev 17685)
@@ -388,6 +388,9 @@
((gnc:html-scatter? obj)
(set! o (gnc:make-html-object-internal
gnc:html-scatter-render obj)))
+ ((gnc:html-linechart? obj)
+ (set! o (gnc:make-html-object-internal
+ gnc:html-linechart-render obj)))
((gnc:html-object? obj)
(set! o obj))
Added: gnucash/trunk/src/report/report-system/html-linechart.scm
===================================================================
--- gnucash/trunk/src/report/report-system/html-linechart.scm (rev 0)
+++ gnucash/trunk/src/report/report-system/html-linechart.scm 2008-11-08 13:40:33 UTC (rev 17685)
@@ -0,0 +1,954 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; html-linechart.scm : generate HTML programmatically, with support
+;; for simple style elements.
+;; Copyright 2008 Sven Henkel <shenkel at gmail.com>
+;;
+;; Adapted from html-barchart.scm which is
+;; Copyright 2000 Bill Gribble <grib at 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
+;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
+;; Boston, MA 02110-1301, USA gnu at gnu.org
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define <html-linechart>
+ (make-record-type "<html-linechart>"
+ '(width
+ height
+ title
+ subtitle
+ x-axis-label
+ y-axis-label
+ col-labels
+ row-labels
+ col-colors
+ legend-reversed?
+ row-labels-rotated?
+ stacked?
+ markers?
+ major-grid?
+ minor-grid?
+ data
+ button-1-line-urls
+ button-2-line-urls
+ button-3-line-urls
+ button-1-legend-urls
+ button-2-legend-urls
+ button-3-legend-urls)))
+
+(define gnc:html-linechart?
+ (record-predicate <html-linechart>))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; <html-linechart> class
+;; generate the <object> form for a guppi linechart.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define gnc:make-html-linechart-internal
+ (record-constructor <html-linechart>))
+
+(define (gnc:make-html-linechart)
+ (gnc:make-html-linechart-internal -1 -1 #f #f #f #f '() '() '()
+ #f #f #f #f #f #f '()
+ #f #f #f #f #f #f))
+
+(define gnc:html-linechart-data
+ (record-accessor <html-linechart> 'data))
+
+(define gnc:html-linechart-set-data!
+ (record-modifier <html-linechart> 'data))
+
+(define gnc:html-linechart-width
+ (record-accessor <html-linechart> 'width))
+
+(define gnc:html-linechart-set-width!
+ (record-modifier <html-linechart> 'width))
+
+(define gnc:html-linechart-height
+ (record-accessor <html-linechart> 'height))
+
+(define gnc:html-linechart-set-height!
+ (record-modifier <html-linechart> 'height))
+
+(define gnc:html-linechart-x-axis-label
+ (record-accessor <html-linechart> 'x-axis-label))
+
+(define gnc:html-linechart-set-x-axis-label!
+ (record-modifier <html-linechart> 'x-axis-label))
+
+(define gnc:html-linechart-y-axis-label
+ (record-accessor <html-linechart> 'y-axis-label))
+
+(define gnc:html-linechart-set-y-axis-label!
+ (record-modifier <html-linechart> 'y-axis-label))
+
+(define gnc:html-linechart-row-labels
+ (record-accessor <html-linechart> 'row-labels))
+
+(define gnc:html-linechart-set-row-labels!
+ (record-modifier <html-linechart> 'row-labels))
+
+(define gnc:html-linechart-row-labels-rotated?
+ (record-accessor <html-linechart> 'row-labels-rotated?))
+
+(define gnc:html-linechart-set-row-labels-rotated?!
+ (record-modifier <html-linechart> 'row-labels-rotated?))
+
+(define gnc:html-linechart-stacked?
+ (record-accessor <html-linechart> 'stacked?))
+
+(define gnc:html-linechart-set-stacked?!
+ (record-modifier <html-linechart> 'stacked?))
+
+(define gnc:html-linechart-markers?
+ (record-accessor <html-linechart> 'markers?))
+
+(define gnc:html-linechart-set-markers?!
+ (record-modifier <html-linechart> 'markers?))
+
+(define gnc:html-linechart-major-grid?
+ (record-accessor <html-linechart> 'major-grid?))
+
+(define gnc:html-linechart-set-major-grid?!
+ (record-modifier <html-linechart> 'major-grid?))
+
+(define gnc:html-linechart-minor-grid?
+ (record-accessor <html-linechart> 'minor-grid?))
+
+(define gnc:html-linechart-set-minor-grid?!
+ (record-modifier <html-linechart> 'minor-grid?))
+
+(define gnc:html-linechart-col-labels
+ (record-accessor <html-linechart> 'col-labels))
+
+(define gnc:html-linechart-set-col-labels!
+ (record-modifier <html-linechart> 'col-labels))
+
+(define gnc:html-linechart-col-colors
+ (record-accessor <html-linechart> 'col-colors))
+
+(define gnc:html-linechart-set-col-colors!
+ (record-modifier <html-linechart> 'col-colors))
+
+(define gnc:html-linechart-legend-reversed?
+ (record-accessor <html-linechart> 'legend-reversed?))
+
+(define gnc:html-linechart-set-legend-reversed?!
+ (record-modifier <html-linechart> 'legend-reversed?))
+
+(define gnc:html-linechart-title
+ (record-accessor <html-linechart> 'title))
+
+(define gnc:html-linechart-set-title!
+ (record-modifier <html-linechart> 'title))
+
+(define gnc:html-linechart-subtitle
+ (record-accessor <html-linechart> 'subtitle))
+
+(define gnc:html-linechart-set-subtitle!
+ (record-modifier <html-linechart> 'subtitle))
+
+;; Note: ATM you can specify one url per column, but this url will be
+;; used for all of the rows. Otherwise we could have cols*rows urls
+;; (quite a lot), but this first requires fixing
+;; guppi_line_1_callback() in gnome/gnc-html-guppi.c .
+(define gnc:html-linechart-button-1-line-urls
+ (record-accessor <html-linechart> 'button-1-line-urls))
+
+(define gnc:html-linechart-set-button-1-line-urls!
+ (record-modifier <html-linechart> 'button-1-line-urls))
+
+(define gnc:html-linechart-button-2-line-urls
+ (record-accessor <html-linechart> 'button-2-line-urls))
+
+(define gnc:html-linechart-set-button-2-line-urls!
+ (record-modifier <html-linechart> 'button-2-line-urls))
+
+(define gnc:html-linechart-button-3-line-urls
+ (record-accessor <html-linechart> 'button-3-line-urls))
+
+(define gnc:html-linechart-set-button-3-line-urls!
+ (record-modifier <html-linechart> 'button-3-line-urls))
+
+(define gnc:html-linechart-button-1-legend-urls
+ (record-accessor <html-linechart> 'button-1-legend-urls))
+
+(define gnc:html-linechart-set-button-1-legend-urls!
+ (record-modifier <html-linechart> 'button-1-legend-urls))
+
+(define gnc:html-linechart-button-2-legend-urls
+ (record-accessor <html-linechart> 'button-2-legend-urls))
+
+(define gnc:html-linechart-set-button-2-legend-urls!
+ (record-modifier <html-linechart> 'button-2-legend-urls))
+
+(define gnc:html-linechart-button-3-legend-urls
+ (record-accessor <html-linechart> 'button-3-legend-urls))
+
+(define gnc:html-linechart-set-button-3-legend-urls!
+ (record-modifier <html-linechart> 'button-3-legend-urls))
+
+(define (gnc:html-linechart-append-row! linechart newrow)
+ (let ((dd (gnc:html-linechart-data linechart)))
+ (set! dd (append dd (list newrow)))
+ (gnc:html-linechart-set-data! linechart dd)))
+
+(define (gnc:html-linechart-prepend-row! linechart newrow)
+ (let ((dd (gnc:html-linechart-data linechart)))
+ (set! dd (cons newrow dd))
+ (gnc:html-linechart-set-data! linechart dd)))
+
+(define (gnc:html-linechart-append-column! linechart newcol)
+ (let ((colnum 0)
+ (rownum 0)
+ (rows (gnc:html-linechart-data linechart))
+ (this-row #f)
+ (new-row #f))
+ ;; find out how many cols are already there in the deepest row
+ (for-each
+ (lambda (row)
+ (let ((l (length row)))
+ (if (> l colnum)
+ (set! colnum l))))
+ rows)
+
+ ;; append the elements of 'newrow' to the rowumns
+ (for-each
+ (lambda (newelt)
+ ;; find the row, or append one
+ (if (not (null? rows))
+ (begin
+ (set! new-row #f)
+ (set! this-row (car rows))
+ (if (null? (cdr rows))
+ (set! rows #f)
+ (set! rows (cdr rows))))
+ (begin
+ (set! new-row #t)
+ (set! this-row '())))
+
+ ;; make sure the rowumn is long enough, then append the data
+ (let loop ((l (length this-row))
+ (r (reverse this-row)))
+ (if (< l colnum)
+ (loop (+ l 1) (cons #f r))
+ (set! this-row
+ (reverse (cons newelt r)))))
+ (if new-row
+ (gnc:html-linechart-append-row! linechart this-row)
+ (list-set! (gnc:html-linechart-data linechart) rownum this-row))
+ (set! rownum (+ 1 rownum)))
+ newcol)))
+
+(define (gnc:not-all-zeros data)
+ (define (myor list)
+ (begin
+ (gnc:debug "list" list)
+ (if (null? list) #f
+ (or (car list) (myor (cdr list))))))
+
+ (cond ((number? data) (not (= 0 data)))
+ ((list? data) (myor (map gnc:not-all-zeros data)))
+ (else #f)))
+
+(define (gnc:html-linechart-prepend-column! linechart newcol)
+ (let ((rows (gnc:html-linechart-data linechart))
+ (this-row #f)
+ (new-row #f)
+ (rownum 0))
+ (for-each
+ (lambda (elt)
+ (if (not (null? rows))
+ (begin
+ (set! new-row #f)
+ (set! this-row (car rows))
+ (if (null? (cdr rows))
+ (set! rows #f)
+ (set! rows (cdr rows))))
+ (begin
+ (set! new-row #t)
+ (set! this-row '())))
+ (if new-row
+ (gnc:html-linechart-append-row! linechart (list elt))
+ (list-set! (gnc:html-linechart-data linechart) rownum
+ (cons elt this-row)))
+ (set! rownum (+ 1 rownum)))
+ newcol)))
+
+(define (gnc:html-linechart-render linechart doc)
+ (define (ensure-numeric elt)
+ (cond ((number? elt)
+ (exact->inexact 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-linechart-title linechart))
+ (subtitle (gnc:html-linechart-subtitle linechart))
+ (url-1
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-1-line-urls linechart)))
+ (url-2
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-2-line-urls linechart)))
+ (url-3
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-3-line-urls linechart)))
+ (legend-1
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-1-legend-urls linechart)))
+ (legend-2
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-2-legend-urls linechart)))
+ (legend-3
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-3-legend-urls linechart)))
+ (x-label (gnc:html-linechart-x-axis-label linechart))
+ (y-label (gnc:html-linechart-y-axis-label linechart))
+ (data (gnc:html-linechart-data linechart))
+ (dummy1 (gnc:debug "data " data))
+ (row-labels (catenate-escaped-strings
+ (gnc:html-linechart-row-labels linechart)))
+ (col-labels (catenate-escaped-strings
+ (gnc:html-linechart-col-labels linechart)))
+ (col-colors (catenate-escaped-strings
+ (gnc:html-linechart-col-colors linechart))))
+ (if (and (list? data)
+ (not (null? data))
+ (gnc:not-all-zeros data))
+ (begin
+ (push "<object classid=\"gnc-guppi-line\" width=")
+ (push (gnc:html-linechart-width linechart))
+ (push " height=")
+ (push (gnc:html-linechart-height linechart))
+ (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 url-1
+ (begin
+ (push " <param name=\"line_urls_1\" value=\"")
+ (push url-1)
+ (push "\">\n")))
+ (if url-2
+ (begin
+ (push " <param name=\"line_urls_2\" value=\"")
+ (push url-2)
+ (push "\">\n")))
+ (if url-3
+ (begin
+ (push " <param name=\"line_urls_3\" value=\"")
+ (push url-3)
+ (push "\">\n")))
+ (if legend-1
+ (begin
+ (push " <param name=\"legend_urls_1\" value=\"")
+ (push legend-1)
+ (push "\">\n")))
+ (if legend-2
+ (begin
+ (push " <param name=\"legend_urls_2\" value=\"")
+ (push legend-2)
+ (push "\">\n")))
+ (if legend-3
+ (begin
+ (push " <param name=\"legend_urls_3\" value=\"")
+ (push legend-3)
+ (push "\">\n")))
+ (if (and data (list? data))
+ (let ((rows (length data))
+ (cols 0))
+ (push " <param name=\"data_rows\" value=\"")
+ (push rows) (push "\">\n")
+ (if (list? (car data))
+ (begin
+ (set! cols (length (car data)))
+ (push " <param name=\"data_cols\" value=\"")
+ (push cols)
+ (push "\">\n")))
+ (push " <param name=\"data\" value=\"")
+ (let loop ((col 0))
+ (for-each
+ (lambda (row)
+ (push (ensure-numeric (list-ref-safe row col)))
+ (push " "))
+ data)
+ (if (< col (- cols 1))
+ (loop (+ 1 col))))
+ (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 (and (string? col-colors) (> (string-length col-colors) 0))
+ (begin
+ (push " <param name=\"col_colors\" value=\"")
+ (push col-colors)
+ (push "\">\n")))
+ (if (and (string? row-labels) (> (string-length row-labels) 0))
+ (begin
+ (push " <param name=\"row_labels\" value=\"")
+ (push row-labels)
+ (push "\">\n")))
+ (if (and (string? col-labels) (> (string-length col-labels) 0))
+ (begin
+ (push " <param name=\"col_labels\" value=\"")
+ (push col-labels)
+ (push "\">\n")))
+ (push " <param name=\"rotate_row_labels\" value=\"")
+ (push (if (gnc:html-linechart-row-labels-rotated? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"stacked\" value=\"")
+ (push (if (gnc:html-linechart-stacked? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"markers\" value=\"")
+ (push (if (gnc:html-linechart-markers? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"major_grid\" value=\"")
+ (push (if (gnc:html-linechart-major-grid? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"minor_grid\" value=\"")
+ (push (if (gnc:html-linechart-minor-grid? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"legend_reversed\" value=\"")
+ (push (if (gnc:html-linechart-legend-reversed? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push "Unable to push line chart\n")
+ (push "</object> \n"))
+ (begin
+ (gnc:warn "linechart has no non-zero data.")
+ " "))
+ retval))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; html-linechart.scm : generate HTML programmatically, with support
+;; for simple style elements.
+;; Copyright 2008 Sven Henkel <shenkel at gmail.com>
+;;
+;; Adapted from html-barchart.scm which is
+;; Copyright 2000 Bill Gribble <grib at 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
+;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
+;; Boston, MA 02110-1301, USA gnu at gnu.org
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define <html-linechart>
+ (make-record-type "<html-linechart>"
+ '(width
+ height
+ title
+ subtitle
+ x-axis-label
+ y-axis-label
+ col-labels
+ row-labels
+ col-colors
+ legend-reversed?
+ row-labels-rotated?
+ stacked?
+ markers?
+ major-grid?
+ minor-grid?
+ data
+ button-1-line-urls
+ button-2-line-urls
+ button-3-line-urls
+ button-1-legend-urls
+ button-2-legend-urls
+ button-3-legend-urls)))
+
+(define gnc:html-linechart?
+ (record-predicate <html-linechart>))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; <html-linechart> class
+;; generate the <object> form for a guppi linechart.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define gnc:make-html-linechart-internal
+ (record-constructor <html-linechart>))
+
+(define (gnc:make-html-linechart)
+ (gnc:make-html-linechart-internal -1 -1 #f #f #f #f '() '() '()
+ #f #f #f #f #f #f '()
+ #f #f #f #f #f #f))
+
+(define gnc:html-linechart-data
+ (record-accessor <html-linechart> 'data))
+
+(define gnc:html-linechart-set-data!
+ (record-modifier <html-linechart> 'data))
+
+(define gnc:html-linechart-width
+ (record-accessor <html-linechart> 'width))
+
+(define gnc:html-linechart-set-width!
+ (record-modifier <html-linechart> 'width))
+
+(define gnc:html-linechart-height
+ (record-accessor <html-linechart> 'height))
+
+(define gnc:html-linechart-set-height!
+ (record-modifier <html-linechart> 'height))
+
+(define gnc:html-linechart-x-axis-label
+ (record-accessor <html-linechart> 'x-axis-label))
+
+(define gnc:html-linechart-set-x-axis-label!
+ (record-modifier <html-linechart> 'x-axis-label))
+
+(define gnc:html-linechart-y-axis-label
+ (record-accessor <html-linechart> 'y-axis-label))
+
+(define gnc:html-linechart-set-y-axis-label!
+ (record-modifier <html-linechart> 'y-axis-label))
+
+(define gnc:html-linechart-row-labels
+ (record-accessor <html-linechart> 'row-labels))
+
+(define gnc:html-linechart-set-row-labels!
+ (record-modifier <html-linechart> 'row-labels))
+
+(define gnc:html-linechart-row-labels-rotated?
+ (record-accessor <html-linechart> 'row-labels-rotated?))
+
+(define gnc:html-linechart-set-row-labels-rotated?!
+ (record-modifier <html-linechart> 'row-labels-rotated?))
+
+(define gnc:html-linechart-stacked?
+ (record-accessor <html-linechart> 'stacked?))
+
+(define gnc:html-linechart-set-stacked?!
+ (record-modifier <html-linechart> 'stacked?))
+
+(define gnc:html-linechart-markers?
+ (record-accessor <html-linechart> 'markers?))
+
+(define gnc:html-linechart-set-markers?!
+ (record-modifier <html-linechart> 'markers?))
+
+(define gnc:html-linechart-major-grid?
+ (record-accessor <html-linechart> 'major-grid?))
+
+(define gnc:html-linechart-set-major-grid?!
+ (record-modifier <html-linechart> 'major-grid?))
+
+(define gnc:html-linechart-minor-grid?
+ (record-accessor <html-linechart> 'minor-grid?))
+
+(define gnc:html-linechart-set-minor-grid?!
+ (record-modifier <html-linechart> 'minor-grid?))
+
+(define gnc:html-linechart-col-labels
+ (record-accessor <html-linechart> 'col-labels))
+
+(define gnc:html-linechart-set-col-labels!
+ (record-modifier <html-linechart> 'col-labels))
+
+(define gnc:html-linechart-col-colors
+ (record-accessor <html-linechart> 'col-colors))
+
+(define gnc:html-linechart-set-col-colors!
+ (record-modifier <html-linechart> 'col-colors))
+
+(define gnc:html-linechart-legend-reversed?
+ (record-accessor <html-linechart> 'legend-reversed?))
+
+(define gnc:html-linechart-set-legend-reversed?!
+ (record-modifier <html-linechart> 'legend-reversed?))
+
+(define gnc:html-linechart-title
+ (record-accessor <html-linechart> 'title))
+
+(define gnc:html-linechart-set-title!
+ (record-modifier <html-linechart> 'title))
+
+(define gnc:html-linechart-subtitle
+ (record-accessor <html-linechart> 'subtitle))
+
+(define gnc:html-linechart-set-subtitle!
+ (record-modifier <html-linechart> 'subtitle))
+
+;; Note: ATM you can specify one url per column, but this url will be
+;; used for all of the rows. Otherwise we could have cols*rows urls
+;; (quite a lot), but this first requires fixing
+;; guppi_line_1_callback() in gnome/gnc-html-guppi.c .
+(define gnc:html-linechart-button-1-line-urls
+ (record-accessor <html-linechart> 'button-1-line-urls))
+
+(define gnc:html-linechart-set-button-1-line-urls!
+ (record-modifier <html-linechart> 'button-1-line-urls))
+
+(define gnc:html-linechart-button-2-line-urls
+ (record-accessor <html-linechart> 'button-2-line-urls))
+
+(define gnc:html-linechart-set-button-2-line-urls!
+ (record-modifier <html-linechart> 'button-2-line-urls))
+
+(define gnc:html-linechart-button-3-line-urls
+ (record-accessor <html-linechart> 'button-3-line-urls))
+
+(define gnc:html-linechart-set-button-3-line-urls!
+ (record-modifier <html-linechart> 'button-3-line-urls))
+
+(define gnc:html-linechart-button-1-legend-urls
+ (record-accessor <html-linechart> 'button-1-legend-urls))
+
+(define gnc:html-linechart-set-button-1-legend-urls!
+ (record-modifier <html-linechart> 'button-1-legend-urls))
+
+(define gnc:html-linechart-button-2-legend-urls
+ (record-accessor <html-linechart> 'button-2-legend-urls))
+
+(define gnc:html-linechart-set-button-2-legend-urls!
+ (record-modifier <html-linechart> 'button-2-legend-urls))
+
+(define gnc:html-linechart-button-3-legend-urls
+ (record-accessor <html-linechart> 'button-3-legend-urls))
+
+(define gnc:html-linechart-set-button-3-legend-urls!
+ (record-modifier <html-linechart> 'button-3-legend-urls))
+
+(define (gnc:html-linechart-append-row! linechart newrow)
+ (let ((dd (gnc:html-linechart-data linechart)))
+ (set! dd (append dd (list newrow)))
+ (gnc:html-linechart-set-data! linechart dd)))
+
+(define (gnc:html-linechart-prepend-row! linechart newrow)
+ (let ((dd (gnc:html-linechart-data linechart)))
+ (set! dd (cons newrow dd))
+ (gnc:html-linechart-set-data! linechart dd)))
+
+(define (gnc:html-linechart-append-column! linechart newcol)
+ (let ((colnum 0)
+ (rownum 0)
+ (rows (gnc:html-linechart-data linechart))
+ (this-row #f)
+ (new-row #f))
+ ;; find out how many cols are already there in the deepest row
+ (for-each
+ (lambda (row)
+ (let ((l (length row)))
+ (if (> l colnum)
+ (set! colnum l))))
+ rows)
+
+ ;; append the elements of 'newrow' to the rowumns
+ (for-each
+ (lambda (newelt)
+ ;; find the row, or append one
+ (if (not (null? rows))
+ (begin
+ (set! new-row #f)
+ (set! this-row (car rows))
+ (if (null? (cdr rows))
+ (set! rows #f)
+ (set! rows (cdr rows))))
+ (begin
+ (set! new-row #t)
+ (set! this-row '())))
+
+ ;; make sure the rowumn is long enough, then append the data
+ (let loop ((l (length this-row))
+ (r (reverse this-row)))
+ (if (< l colnum)
+ (loop (+ l 1) (cons #f r))
+ (set! this-row
+ (reverse (cons newelt r)))))
+ (if new-row
+ (gnc:html-linechart-append-row! linechart this-row)
+ (list-set! (gnc:html-linechart-data linechart) rownum this-row))
+ (set! rownum (+ 1 rownum)))
+ newcol)))
+
+(define (gnc:not-all-zeros data)
+ (define (myor list)
+ (begin
+ (gnc:debug "list" list)
+ (if (null? list) #f
+ (or (car list) (myor (cdr list))))))
+
+ (cond ((number? data) (not (= 0 data)))
+ ((list? data) (myor (map gnc:not-all-zeros data)))
+ (else #f)))
+
+(define (gnc:html-linechart-prepend-column! linechart newcol)
+ (let ((rows (gnc:html-linechart-data linechart))
+ (this-row #f)
+ (new-row #f)
+ (rownum 0))
+ (for-each
+ (lambda (elt)
+ (if (not (null? rows))
+ (begin
+ (set! new-row #f)
+ (set! this-row (car rows))
+ (if (null? (cdr rows))
+ (set! rows #f)
+ (set! rows (cdr rows))))
+ (begin
+ (set! new-row #t)
+ (set! this-row '())))
+ (if new-row
+ (gnc:html-linechart-append-row! linechart (list elt))
+ (list-set! (gnc:html-linechart-data linechart) rownum
+ (cons elt this-row)))
+ (set! rownum (+ 1 rownum)))
+ newcol)))
+
+(define (gnc:html-linechart-render linechart doc)
+ (define (ensure-numeric elt)
+ (cond ((number? elt)
+ (exact->inexact 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-linechart-title linechart))
+ (subtitle (gnc:html-linechart-subtitle linechart))
+ (url-1
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-1-line-urls linechart)))
+ (url-2
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-2-line-urls linechart)))
+ (url-3
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-3-line-urls linechart)))
+ (legend-1
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-1-legend-urls linechart)))
+ (legend-2
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-2-legend-urls linechart)))
+ (legend-3
+ (catenate-escaped-strings
+ (gnc:html-linechart-button-3-legend-urls linechart)))
+ (x-label (gnc:html-linechart-x-axis-label linechart))
+ (y-label (gnc:html-linechart-y-axis-label linechart))
+ (data (gnc:html-linechart-data linechart))
+ (dummy1 (gnc:debug "data " data))
+ (row-labels (catenate-escaped-strings
+ (gnc:html-linechart-row-labels linechart)))
+ (col-labels (catenate-escaped-strings
+ (gnc:html-linechart-col-labels linechart)))
+ (col-colors (catenate-escaped-strings
+ (gnc:html-linechart-col-colors linechart))))
+ (if (and (list? data)
+ (not (null? data))
+ (gnc:not-all-zeros data))
+ (begin
+ (push "<object classid=\"gnc-guppi-line\" width=")
+ (push (gnc:html-linechart-width linechart))
+ (push " height=")
+ (push (gnc:html-linechart-height linechart))
+ (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 url-1
+ (begin
+ (push " <param name=\"line_urls_1\" value=\"")
+ (push url-1)
+ (push "\">\n")))
+ (if url-2
+ (begin
+ (push " <param name=\"line_urls_2\" value=\"")
+ (push url-2)
+ (push "\">\n")))
+ (if url-3
+ (begin
+ (push " <param name=\"line_urls_3\" value=\"")
+ (push url-3)
+ (push "\">\n")))
+ (if legend-1
+ (begin
+ (push " <param name=\"legend_urls_1\" value=\"")
+ (push legend-1)
+ (push "\">\n")))
+ (if legend-2
+ (begin
+ (push " <param name=\"legend_urls_2\" value=\"")
+ (push legend-2)
+ (push "\">\n")))
+ (if legend-3
+ (begin
+ (push " <param name=\"legend_urls_3\" value=\"")
+ (push legend-3)
+ (push "\">\n")))
+ (if (and data (list? data))
+ (let ((rows (length data))
+ (cols 0))
+ (push " <param name=\"data_rows\" value=\"")
+ (push rows) (push "\">\n")
+ (if (list? (car data))
+ (begin
+ (set! cols (length (car data)))
+ (push " <param name=\"data_cols\" value=\"")
+ (push cols)
+ (push "\">\n")))
+ (push " <param name=\"data\" value=\"")
+ (let loop ((col 0))
+ (for-each
+ (lambda (row)
+ (push (ensure-numeric (list-ref-safe row col)))
+ (push " "))
+ data)
+ (if (< col (- cols 1))
+ (loop (+ 1 col))))
+ (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 (and (string? col-colors) (> (string-length col-colors) 0))
+ (begin
+ (push " <param name=\"col_colors\" value=\"")
+ (push col-colors)
+ (push "\">\n")))
+ (if (and (string? row-labels) (> (string-length row-labels) 0))
+ (begin
+ (push " <param name=\"row_labels\" value=\"")
+ (push row-labels)
+ (push "\">\n")))
+ (if (and (string? col-labels) (> (string-length col-labels) 0))
+ (begin
+ (push " <param name=\"col_labels\" value=\"")
+ (push col-labels)
+ (push "\">\n")))
+ (push " <param name=\"rotate_row_labels\" value=\"")
+ (push (if (gnc:html-linechart-row-labels-rotated? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"stacked\" value=\"")
+ (push (if (gnc:html-linechart-stacked? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"markers\" value=\"")
+ (push (if (gnc:html-linechart-markers? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"major_grid\" value=\"")
+ (push (if (gnc:html-linechart-major-grid? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"minor_grid\" value=\"")
+ (push (if (gnc:html-linechart-minor-grid? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push " <param name=\"legend_reversed\" value=\"")
+ (push (if (gnc:html-linechart-legend-reversed? linechart)
+ "1\">\n"
+ "0\">\n"))
+ (push "Unable to push line chart\n")
+ (push "</object> \n"))
+ (begin
+ (gnc:warn "linechart has no non-zero data.")
+ " "))
+ retval))
Modified: gnucash/trunk/src/report/report-system/report-system.scm
===================================================================
--- gnucash/trunk/src/report/report-system/report-system.scm 2008-11-07 21:59:09 UTC (rev 17684)
+++ gnucash/trunk/src/report/report-system/report-system.scm 2008-11-08 13:40:33 UTC (rev 17685)
@@ -315,6 +315,63 @@
(export gnc:html-scatter-add-datapoint!)
(export gnc:html-scatter-render)
+;; html-linechart.scm
+
+(export <html-linechart>)
+(export gnc:html-linechart? )
+(export gnc:make-html-linechart-internal)
+(export gnc:make-html-linechart)
+(export gnc:html-linechart-data)
+(export gnc:html-linechart-set-data!)
+(export gnc:html-linechart-width)
+(export gnc:html-linechart-set-width!)
+(export gnc:html-linechart-height)
+(export gnc:html-linechart-set-height!)
+(export gnc:html-linechart-x-axis-label)
+(export gnc:html-linechart-set-x-axis-label!)
+(export gnc:html-linechart-y-axis-label)
+(export gnc:html-linechart-set-y-axis-label!)
+(export gnc:html-linechart-row-labels)
+(export gnc:html-linechart-set-row-labels!)
+(export gnc:html-linechart-row-labels-rotated?)
+(export gnc:html-linechart-set-row-labels-rotated?!)
+(export gnc:html-linechart-stacked?)
+(export gnc:html-linechart-set-stacked?!)
+(export gnc:html-linechart-markers?)
+(export gnc:html-linechart-set-markers?!)
+(export gnc:html-linechart-major-grid?)
+(export gnc:html-linechart-set-major-grid?!)
+(export gnc:html-linechart-minor-grid?)
+(export gnc:html-linechart-set-minor-grid?!)
+(export gnc:html-linechart-col-labels)
+(export gnc:html-linechart-set-col-labels!)
+(export gnc:html-linechart-col-colors)
+(export gnc:html-linechart-set-col-colors!)
+(export gnc:html-linechart-legend-reversed?)
+(export gnc:html-linechart-set-legend-reversed?!)
+(export gnc:html-linechart-title)
+(export gnc:html-linechart-set-title!)
+(export gnc:html-linechart-subtitle)
+(export gnc:html-linechart-set-subtitle!)
+(export gnc:html-linechart-button-1-line-urls)
+(export gnc:html-linechart-set-button-1-line-urls!)
+(export gnc:html-linechart-button-2-line-urls)
+(export gnc:html-linechart-set-button-2-line-urls!)
+(export gnc:html-linechart-button-3-line-urls)
+(export gnc:html-linechart-set-button-3-line-urls!)
+(export gnc:html-linechart-button-1-legend-urls)
+(export gnc:html-linechart-set-button-1-legend-urls!)
+(export gnc:html-linechart-button-2-legend-urls)
+(export gnc:html-linechart-set-button-2-legend-urls!)
+(export gnc:html-linechart-button-3-legend-urls)
+(export gnc:html-linechart-set-button-3-legend-urls!)
+(export gnc:html-linechart-append-row!)
+(export gnc:html-linechart-prepend-row!)
+(export gnc:html-linechart-append-column!)
+(export gnc:html-linechart-prepend-column!)
+(export gnc:html-linechart-render linechart)
+
+
;; html-style-info.scm
(export make-kvtable)
@@ -609,6 +666,7 @@
(load-from-path "html-document.scm")
(load-from-path "html-piechart.scm")
(load-from-path "html-scatter.scm")
+(load-from-path "html-linechart.scm")
(load-from-path "html-style-info.scm")
(load-from-path "html-style-sheet.scm")
More information about the gnucash-changes
mailing list