File Coverage

blib/lib/Tk/PlotDataset.pm
Criterion Covered Total %
statement 18 18 100.0
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 24 24 100.0


line stmt bran cond sub pod time code
1             package Tk::PlotDataset;
2              
3             =head1 NAME
4              
5             PlotDataset - An extended version of the canvas widget for plotting 2D line
6             graphs. Plots have a legend, zooming capabilities and the option
7             to display error bars.
8              
9             =head1 SYNOPSIS
10              
11             use Tk;
12             use Tk::PlotDataset;
13             use Tk::LineGraphDataset;
14              
15             my $main_window = MainWindow -> new;
16              
17             my @data1 = (0..25);
18             my @errors1 = map { rand(2) } ( 0..25 );
19             my $dataset1 = LineGraphDataset -> new
20             (
21             -name => 'Data Set One',
22             -yData => \@data1,
23             -yError => \@errors1,
24             -yAxis => 'Y',
25             -color => 'purple'
26             );
27              
28             my @data2x = (0..25);
29             my @data2y = ();
30             foreach my $xValue (@data2x)
31             {
32             push (@data2y, $xValue ** 2);
33             }
34             my $dataset2 = LineGraphDataset -> new
35             (
36             -name => 'Data Set Two',
37             -xData => \@data2x,
38             -yData => \@data2y,
39             -yAxis => 'Y1',
40             -color => 'blue'
41             );
42              
43             my $graph = $main_window -> PlotDataset
44             (
45             -width => 500,
46             -height => 500,
47             -background => 'snow'
48             ) -> pack(-fill => 'both', -expand => 1);
49              
50             $graph -> addDatasets($dataset1, $dataset2);
51              
52             $graph -> plot;
53              
54             MainLoop;
55              
56             =head1 STANDARD OPTIONS
57              
58             -background -highlightthickness -takefocus -selectborderwidth
59             -borderwidth -insertbackground -relief -tile
60             -cursor -insertborderwidth -selectbackground -xscrollcommand
61             -insertwidth -highlightbackground -insertofftime -yscrollcommand
62             -state -highlightcolor -insertontime -selectforeground
63              
64             =head1 WIDGET-SPECIFIC OPTIONS
65              
66             In addition to all the Canvas options, the following option/value pairs are
67             supported. All of these options can be set with the new() method when the
68             PlotDataset object is created or by using configure():
69              
70             =over 4
71              
72             =item -colors
73              
74             An array of colours to use for the display of the datasets. If there are more
75             datasets than colours in the array then the colours will cycle. This option
76             will be overwritten if the LineGraphDataset object already has a colour
77             assigned to it.
78              
79             This option only has an effect when datasets are plotted and therefore changing
80             the array will not change the colour of the plots already on the graph. To
81             change existing plots the colour must be set in the LineGraphDataset object or
82             the dataset re-added to the graph.
83              
84             =item -pointShapes
85              
86             An array of point shapes to use for the display of the datasets. If there are
87             more datasets than shapes in the array then the shapes will cycle. These shapes
88             will be overwritten if the LineGraphDataset object already has a point shape
89             assigned to it. Valid shapes are none, circle, square, triangle and diamond.
90              
91             Like the -colors, this option only has an effect when datasets are plotted and
92             therefore changing the array will not change the point shapes of the plots
93             already on the graph.
94              
95             =item -border
96              
97             An array of four numbers which are the width of the border between the plot area
98             and the canvas. The order is North (top), East (right), South (bottom) and West
99             (left). By default, the borders are 25, 50, 100 and 50 respectively.
100              
101             =item -zoomButton
102              
103             Selects the mouse button used for zooming in and out. The value must be a
104             number from 1 to 5 corresponding to the five potential mouse buttons, any other
105             value will disable zooming on the graph. Typically the left mouse button is 1
106             (default) and the right is 3.
107              
108             =item -scale
109              
110             A nine element array of the minimum, maximum and step values of scales on each
111             of the three axes - x, y, and y1. The order of the nine values is xMin, xMax,
112             xStep, yMin, yMax, yStep, y1Min, y1Max and y1Step. The default values for all
113             the axis are 0 to 100 with a step size of 10. This option will only affect axes
114             where the auto-scale option has been turned off.
115              
116             An axis can be reversed by swapping its minimum and maximum values around.
117              
118             =item -plotTitle
119              
120             A two element array. The first element is the plot title, the second element is
121             the vertical offset of the title above the top of the graph. The title is centered
122             in the x direction.
123              
124             =item -xlabel
125              
126             The text label for the x-axis. The text is centered on the X-axis.
127              
128             =item -ylabel
129              
130             The text label for the y-axis. The text is centered on the Y-axis.
131              
132             =item -y1label
133              
134             The text label for the y1-axis, which is the optional axis to the right of the
135             plot. The text is centered on the y1-axis. The label will only be displayed if
136             there are datasets using the y1-axis.
137              
138             =item -xlabelPos
139              
140             The vertical position of the x-axis label, relative to the bottom of the plot
141             area. The default for this value is 40.
142              
143             =item -ylabelPos
144              
145             The vertical position of the y-axis label, relative to the left of the plot
146             area. The default for this value is 40.
147              
148             =item -y1labelPos
149              
150             The vertical position of the y1-axis label, relative to the right of the plot
151             area. The default for this value is 40.
152              
153             =item -xTickFormat
154              
155             This option can be used to override the default format strings, as used by
156             sprintf, to generate the tick labels on the x-axis. In linear mode the default
157             is '%.3g', in log mode '1e%3.2d' will be used for values less than zero and
158             '1e+%2.2d' will be used for values of zero or more. If you override this
159             format, it will apply to all values in all modes of the x-axis.
160              
161             =item -yTickFormat
162              
163             This option can be used to override the default format strings, as used by
164             sprintf, to generate the tick labels on the y-axis. In linear mode the default
165             is '%.3g', in log mode '1e%3.2d' will be used for values less than zero and
166             '1e+%2.2d' will be used for values of zero or more. If you override this
167             format, it will apply to all values in all modes of the y-axis.
168              
169             =item -y1TickFormat
170              
171             This option can be used to override the default format strings, as used by
172             sprintf, to generate the tick labels on the y1-axis. In linear mode the default
173             is '%.3g', in log mode '1e%3.2d' will be used for values less than zero and
174             '1e+%2.2d' will be used for values of zero or more. If you override this
175             format, it will apply to all values in all modes of the y1-axis. The y1-axis
176             ticks will only be displayed if there are datasets using the y1-axis.
177              
178             =item -balloons
179              
180             Should be set to a true value (eg. 1) in order to enable coordinate balloons,
181             or a false value (eg. 0) to disable them. Coordinate balloons are enabled by
182             default.
183              
184             =item -legendPos
185              
186             A two element array which specifies the position of the legend. The first
187             element specifies where the legend should be, either 'bottom' for below the
188             chart, and 'side' for the right side of the chart. The second element is the
189             distance from the edge of the chart to the legend. By default, the legend is 80
190             pixels below the chart.
191              
192             =item -xType
193              
194             The scale type of the x-axis. Can be linear or log. The default type is
195             linear.
196              
197             =item -yType
198              
199             The scale type of the y-axis. Can be linear or log. The default type is
200             linear.
201              
202             =item -y1Type
203              
204             The scale type of the y1 axis. Can be linear or log. The default type is
205             linear.
206              
207             =item -showError
208              
209             Should be set to a true value (eg. 1) to show the error bars or a false value
210             (eg. 0) to hide them. By default, error bars will be automatically shown for
211             datasets with error data.
212              
213             =item -maxPoints
214              
215             Sets the threshold at which the points on the plot will be marked. If the
216             number of points on the plot is greater than this value then individual points
217             will not be shown. Points for datasets with no line will always be shown. If
218             points are shown on a plot then so will any associated error bars.
219              
220             =item -logMin
221              
222             Applies to all logarithmic axes. A replacement value for zero or negative
223             values that cannot be plotted on a logarithmic axis. The default value is 1e-3.
224              
225             =item -fonts
226              
227             A four element array with the font names for the various labels in the plot.
228             The first element is the font of the numbers at the axes ticks, the second is
229             the font for the axes labels (all of them), the third is the plot title font
230             and fourth is the font for the legend.
231              
232             $graph -> configure
233             (
234             -fonts =>
235             [
236             'Times 8 bold',
237             'Courier 8 italic',
238             'Arial 12 bold',
239             'Arial 10'
240             ]
241             );
242              
243             The format for each font string is; the name of the font, followed by its size
244             and then whether it should be in bold, italic or underlined.
245              
246             =item -autoScaleX
247              
248             When set to "On" the x-axis will be scaled to the values to be plotted. Default
249             is "On". "Off" is the other possible value.
250              
251             =item -autoScaleY
252              
253             When set to "On" the y-axis will be scaled to the values to be plotted. Default
254             is "On". "Off" is the other possible value.
255              
256             =item -autoScaleY1
257              
258             When set to "On" the y1-axis will be scaled to the values to be plotted.
259             Default is "On". "Off" is the other possible value.
260              
261             =item -redraw
262              
263             A subroutine that is called when the graph is redrawn. It can be used to redraw
264             widgets, such as buttons, that have been added to the graph's canvas. Without
265             the subroutine anything on the graph would be overwritten.
266              
267             $graph -> configure
268             (
269             -redraw => sub
270             {
271             my $button = $graph -> Button(-text => 'Button');
272             $graph -> createWindow
273             (
274             $graph -> cget(-width) - 8, $graph -> cget(-height) - 8,
275             -anchor => 'se', -height => 18, -width => 100,
276             -window => $button
277             );
278             }
279             );
280              
281             =back
282              
283             =head2 Tk::LineGraphDataset Options
284              
285             In addition to the standard options of the LineGraphDataset module, it is also
286             possible to use additional options for use with PlotDataset. Please note that
287             these options will only have an effect on PlotDataset and no other module and
288             hence are not documented in LineGraphDataset.
289              
290             =over 4
291              
292             =item -yError
293              
294             Array of numeric values used to indicate the error, or uncertainty in the y-data.
295             This is an optional array, but if it is specified it must be the same length as the
296             -yData array. By default, Tk::PlotDataset will display error bars for any dataset
297             with error data. Error values are assumed to be symmetrical i.e. positive error
298             margin is the same as the negative error margin. Only the magnitude of the error
299             data is used, so the sign of negative values will always be ignored.
300              
301             =item -pointSize
302              
303             Sets the size of the points in the dataset's plot. The value can be any
304             positive integer. The default for this value is 3.
305              
306             =item -pointStyle
307              
308             A string which sets the shape of the point for the dataset's plot. Setting this
309             option will override Tk::PlotDataset's -pointShapes option for the dataset.
310             Like the -pointShapes option, valid shapes are none, circle, square, triangle
311             and diamond.
312              
313             =item -lineStyle
314              
315             A string which sets the pattern of the line for the dataset's plot. Valid
316             patterns are normal (solid line), dot, dash, dotdash and none. By default, all
317             lines will be solid.
318              
319             =item -fillPoint
320              
321             A boolean value which determines the appearance of the dataset's points. If the
322             value is true (eg. 1), the point is a solid colour, otherwise (eg. 0) only an
323             outline of the point is shown. By default, all points will be filled.
324              
325             =back
326              
327             =head1 DESCRIPTION
328              
329             PlotDataset is a quick and easy way to build an interactive plot widget into a
330             Perl application. The module is written entirely in Perl/Tk.
331              
332             The widget is an extension of the Canvas widget that will plot LineGraphDataset
333             objects as lines onto a 2D graph. The axes can be automatically scaled or set by
334             the code. The axes can have linear or logarithmic scales and there is also an
335             option of an additional y-axis (y1).
336              
337             By default, plots for datasets which contain error data will include error bars.
338              
339             =head2 Behaviour
340              
341             When the mouse cursor passes over a plotted line or its entry in the legend,
342             the line and its entry will turn red to help identify it. Holding the cursor
343             over a point on the graph will display the point's coordinates in a help
344             balloon (unless disabled). Individual points are not shown when the number of
345             points in the plot is greater than the value set by the -maxPoints option. The
346             default number of points is 20.
347              
348             By default, the left button (button-1) is used to zoom a graph. Move the cursor
349             to one of the corners of the box into which you want the graph to zoom. Hold
350             down the mouse button and move to the opposite corner. Release the mouse button
351             and the graph will zoom into the box. To undo one level of zoom click the mouse
352             button without moving the cursor.
353              
354             =head1 WIDGET METHODS
355              
356             The PlotDataset (or new) method creates a widget object. This object supports
357             the configure and cget methods described in the Tk::options manpage, which can
358             be used to enquire and modify the options described above (except -colors and
359             -pointShapes). The widget also inherits all the methods provided by the
360             Tk::Canvas class.
361              
362             In addition, the module provides its own methods, described below:
363              
364             =over 4
365              
366             =item $plot_dataset -> addDatasets ( dataset1 , dataset2 , ... )
367              
368             Adds one or more dataset objects to the plot. Call the plot() method afterwards
369             to see the newly added datasets.
370              
371             =item $plot_dataset -> clearDatasets
372              
373             Removes all the datasets from the plot. Call the plot() method afterwards to
374             clear the graph.
375              
376             =item $plot_dataset -> plot ( rescale )
377              
378             Updates the graph to include changes to the graph's configuration or datasets.
379             The parameter rescale can be one of three options:
380              
381             =over 4
382              
383             =item Z<>
384              
385             'always' to always rescale plot. This is the default.
386              
387             'never' to never rescale plot.
388              
389             'not_zoomed' to only rescale when the plot is not zoomed in.
390              
391             =back
392              
393             B Changes to the graph's configuration or datasets will also be applied
394             when the graph is rescaled when zooming in or out.
395              
396             =back
397              
398             =head1 HISTORY
399              
400             This Tk widget is based on the Tk::LineGraph module by Tom Clifford. Due to
401             trouble with overriding methods that call methods using SUPER:: LineGraph could
402             not be used as a base class.
403              
404             The main difference between this module and the original is that the graph is
405             created as a widget and not in a separate window. It therefore does not have
406             the drop down menus used to configure the graph in the original.
407              
408             Other additions/alterations are:
409              
410             =over 4
411              
412             =item Z<>
413              
414             - Used Tk::Balloon to add optional coordinate pop-ups to data points.
415              
416             - Running the cursor over a line name in the legend will highlight the curve on
417             the graph.
418              
419             - Added a clearDatasets method for removing all datasets from a plot.
420              
421             - Added support for a -noLegend option for datasets, allowing them to be
422             excluded from the legend.
423              
424             - Added support for the -pointSize, -pointStyle, -lineStyle and -fillPoint
425             LineGraphDataset options.
426              
427             - Added -redraw option to allow a callback to be added to draw additional items
428             onto the canvas when it is redrawn.
429              
430             - Option for a logarithmic scale on the x-axis (previously this was only
431             available on the y-axis).
432              
433             - Changed the legend so that it displays an example line and point. This legend
434             can be either at the bottom or side of the chart.
435              
436             - Added -xTickFormat, -yTickFormat and -y1TickFormat options to configure the
437             format of the number labels on each axis.
438              
439             - Removed all bindings to the mouse buttons except for zooming. The mouse
440             button used for zooming can be configured.
441              
442             - Support for plotting y-error bars added by Thomas Pissulla.
443              
444             =back
445              
446             A number of bugs in the original code have also been found and fixed:
447              
448             =over 4
449              
450             =item Z<>
451              
452             - Plots could be dragged using button 3 - this is not useful.
453              
454             - If less than ten colours were provided, then the colour usage failed to cycle
455             and caused an error.
456              
457             - If the user zooms beyond a range of approximately 1e-15, then it hangs.
458              
459             - Scale values of 0 were frequently displayed as very small numbers
460             (approximately 1e-17).
461              
462             - Small grey boxes were sometimes left behind when zooming out.
463              
464             - In places, -tags was passed a string instead of an array reference, which
465             caused problems especially in the legends method.
466              
467             - Corrected an issue with the positioning of the y1 axis label.
468              
469             - Corrected a divide by zero error occurring when a vertical data line passes
470             through a zoomed plot.
471              
472             - Fixed a memory leak that occurred when the value passed to the configure
473             method was an array reference.
474              
475             =back
476              
477             =head1 BUGS
478              
479             Currently there are no known bugs, but there are a couple of the limitations to
480             the module:
481              
482             =over 4
483              
484             =item Z<>
485              
486             - If no data on the graph is plotted on the y-axis, i.e. the y1-axis is used
487             instead, then it is not possible to zoom the graph. It will also not be
488             possible to zoom the graph if y1-axis has a log scale but no data.
489              
490             - In the case where the number of points in the x and y axes are different the
491             points with missing values are not plotted.
492              
493             - Currently, if zero or negative numbers are plotted on a logarithmic scale
494             their values are set to the value of -logMin. This can produce strange looking
495             graphs when using mixed type axes. A future improvement would be to provide an
496             option to omit non-valid points from the graph.
497              
498             - The widget does not work with the Tk::Scrolled module.
499              
500             =back
501              
502             =head1 COPYRIGHT
503              
504             Copyright 2013 I.T. Dev Ltd.
505              
506             This library is free software; you can redistribute it and/or modify it under
507             the same terms as Perl itself.
508              
509             Any code from the original Tk::LineGraph module is the copyright of Tom
510             Clifford.
511              
512             =head1 AUTHOR
513              
514             Andy Culmer, Tim Culmer and Stephen Spain.
515             Contact via website - http://www.itdev.co.uk
516              
517             Original code for the Tk::LineGraph module by Tom Clifford.
518              
519             =head1 CONTRIBUTORS
520              
521             Y-Error Bars by Thomas Pissulla.
522             Contact via website - http://www.ikp.uni-koeln.de/~pissulla
523              
524             =head1 SEE ALSO
525              
526             Tk::LineGraph Tk::LineGraphDataset
527              
528             =head1 KEYWORDS
529              
530             Plot 2D Axis
531              
532             =cut
533              
534             # Internal Revision History
535             #
536             # Filename : PlotDataset.pm
537             # Authors : ac - Andy Culmer, I.T. Dev Limited
538             # tc - Tim Culmer, I.T. Dev Limited
539             # ss - Stephen Spain, I.T. Dev Limited
540             #
541             # pi - Thomas Pissulla, Institute for Nuclear Physics, University of Cologne
542             #
543             # Version 1 by ac on 19/12/2006
544             # Initial Version, modified from Tk::LineGraph.
545             #
546             # Version 2 by ac on 05/01/2007
547             # Changed the resize behaviour to allow the graph to be used with other widgets
548             # in the same window. This makes this widget more consistent with other Tk
549             # widgets.
550             #
551             # Version 3 by ac on 10/01/2007
552             # Added clearDatasets method to remove all datasets from a plot.
553             # Added support for a -noLine option for datasets, allowing them to be plotted
554             # points only.
555             # Added support for a noLegend option for datasets, allowing them to be excluded
556             # from the legend.
557             #
558             # Version 4 by ac on 23/01/2007
559             # Added -redraw option to allow a callback to be added to draw additional items
560             # onto the canvas when it is redrawn. Also corrected an issue with the
561             # positioning of the Y1 axis label.
562             #
563             # Version 5 by ac on 06/03/2007
564             # Corrected a divide by zero error occurring when a vertical data line passes
565             # through a zoomed plot.
566             #
567             # Version 6 by tc on 04/04/2007
568             # Prepared the module for submitting to CPAN.
569             # * Removed unused code.
570             # * Renamed the variables that use the reserved $a and $b variable names.
571             # * Attempted to make the original TK::LineGraph source code conform to the
572             # I.T. Dev coding standard.
573             # * Added an option for a logarithmic scale on the x-axis.
574             # * Added to original POD documentation.
575             #
576             # Version 7 by tc on 14/05/2007
577             # Fixed a couple of issues that occur when using log axes:
578             # * When using autoscale a log axis will always include an extra set of ticks
579             # than is needed.
580             # * If the y or y1 axis is longer than the x axis then the axis ticks are
581             # labelled with the font information.
582             # * The y1 axis has no log ticks.
583             #
584             # Version 8 by ss on 16/05/2007
585             # Added some extra functionality
586             # * Added -lineStyle dataset option to set the style of a line.
587             # * Added -pointStyle dataset option to set the style of a point.
588             # * Added -pointSize dataset option to set the size of a point
589             # * Added -fillPoint dataset option to set whether a point should be filled.
590             # * Added -xlabelPos, -ylabelPos, and -y1labelPos plot options to specify
591             # the distance these labels should be from the plot area.
592             # * Added extra information to the legend, to show the line style and point
593             # style for each line.
594             # * Added -legendPos plot option to allow the legend to be placed either at
595             # the side or bottom of the plot area, and specify the distance between the
596             # legend and the plot area.
597             # Fixed some issues:
598             # * When no x data was specified _data_sets_min_max() assumed there was one
599             # extra data point on the x axis, so scaled wrongly.
600             # * Graphs with '-noLine' set, but less than 20 points on the screen are not
601             # visible until the user zooms.
602             # * Fixed a problem with the alignment of the x-axis label.
603             # * Fixed a problem with the alignment of the title.
604             #
605             # Version 9 by ss on 23/05/2007
606             # Fixed a problem with legend where a line was shown when -lineStyle was set to
607             # none.
608             #
609             # Version 10 by tc on 01/06/2007
610             # Modified code to meet I.T. Dev Perl Coding Standard and to comply more with
611             # the perlstyle documentation. Functionality not changed.
612             #
613             # Version 11 by ac on 06/11/2007
614             # New features:
615             # * Added -xTickFormat, -yTickFormat and -y1TickFormat options to configure
616             # the format of the number labels on each axis.
617             # * Added -balloons option to enable/disable the coordinates balloons.
618             # Bug fixes:
619             # * Fixed a memory leak that occurred when the value passed to the configure
620             # method was an array reference.
621             #
622             # Version 12 by tc on 09/11/2007
623             # Documented the additional LineGraphDataset options supported by the module.
624             # Removed support for the -noLine option in LineGraphDataset - its
625             # functionality is now incorporated in the -lineStyle option.
626             #
627             # Version 13 by tc on 02/01/2008
628             # Wraps legend when it is displayed at the bottom of the graph. Added the
629             # -zoomButton option.
630             #
631             # Version 14 by tc on 02/11/2012
632             # Added support for reversing an axis by swapping its minimum and maximum
633             # scale values around.
634             #
635             # Version 15 by pi on 11/04/2013
636             # Added support for y-error bars.
637              
638 2     2   48020 use strict;
  2         4  
  2         77  
639 2     2   29 use warnings;
  2         3  
  2         78  
640              
641 2     2   57 use 5.005_03;
  2         14  
  2         73  
642              
643 2     2   11 use Carp;
  2         2  
  2         179  
644 2     2   1701 use POSIX;
  2         14058  
  2         12  
645 2     2   6105 use base qw/Tk::Derived Tk::Canvas/;
  2         4  
  2         1504  
646             use Tk::Balloon;
647             use vars qw($VERSION);
648              
649             $VERSION = '2.04';
650              
651             Construct Tk::Widget 'PlotDataset';
652              
653             sub ClassInit ## no critic (NamingConventions::ProhibitMixedCaseSubs)
654             {
655             my ($class, $mw ) = @_;
656             $class -> SUPER::ClassInit($mw);
657              
658             return (1);
659             }
660              
661             # Class data to track mega-item items. Not used as yet.
662             my $id = 0;
663             my %ids = ();
664              
665             sub Populate ## no critic (NamingConventions::ProhibitMixedCaseSubs)
666             {
667             my ($self, $args) = @_;
668              
669             my @def_colors =
670             qw/
671             gray SlateBlue1 blue1 DodgerBlue4 DeepSkyBlue2 SeaGreen3
672             green4 khaki4 gold3 gold1 firebrick1 brown4 magenta1 purple1 HotPink1
673             chocolate1 black
674             /;
675             my @def_point_shapes = qw/circle square triangle diamond/;
676             $self -> ConfigSpecs
677             (
678             -colors => ['PASSIVE', 'colors', 'Colors', \@def_colors],
679             -pointShapes => ['PASSIVE', 'pointShapes', 'PointShapes', \@def_point_shapes],
680             -border => ['PASSIVE', 'border', 'Border', [25, 50, 100, 50]],
681             -scale => ['PASSIVE', 'scale', 'Scale', [0, 100, 10, 0, 100, 10, 0, 100, 10]],
682             -zoom => ['PASSIVE', 'zoom', 'Zoom', [0, 0, 0, 0, 0]],
683             -plotTitle => ['PASSIVE', 'plottitle', 'PlotTitle', ['Default Plot Title', 25 ]],
684             -xlabel => ['PASSIVE', 'xlabel', 'Xlabel', 'X Axis Default Label'],
685             -ylabel => ['PASSIVE', 'ylabel', 'Ylabel', 'Y Axis Default Label'],
686             -y1label => ['PASSIVE', 'Y1label', 'Y1label', 'Y1 Axis Default Label'],
687             -xlabelPos => ['PASSIVE', 'xlabelPos', 'XlabelPos', 40],
688             -ylabelPos => ['PASSIVE', 'ylabelPos', 'YlabelPos', 40],
689             -y1labelPos => ['PASSIVE', 'Y1labelPos', 'Y1labelPos', 40],
690             -xTickLabel => ['PASSIVE', 'xticklabel', 'Xticklabel', undef],
691             -yTickLabel => ['PASSIVE', 'yticklabel', 'Yticklabel', undef],
692             -y1TickLabel => ['PASSIVE', 'y1ticklabel', 'Y1ticklabel', undef],
693             -xTickFormat => ['PASSIVE', 'xtickformat', 'Xtickformat', undef],
694             -yTickFormat => ['PASSIVE', 'ytickformat', 'Ytickformat', undef],
695             -y1TickFormat => ['PASSIVE', 'y1tickformat', 'Y1tickformat', undef],
696             -balloons => ['PASSIVE', 'balloons', 'Balloons', 1],
697             -legendPos => ['PASSIVE', 'legendPos', 'LegendPos', ['bottom', 80]],
698             -xType => ['PASSIVE', 'xtype', 'Xtype', 'linear'], # could be log
699             -yType => ['PASSIVE', 'ytype', 'Ytype', 'linear'], # could be log
700             -y1Type => ['PASSIVE', 'y1type', 'Y1type', 'linear'], # could be log
701             -fonts => ['PASSIVE', 'fonts', 'Fonts', ['Arial 8', 'Arial 8', 'Arial 10 bold', 'Arial 10']],
702             -autoScaleY => ['PASSIVE', 'autoscaley', 'AutoScaleY', 'On'],
703             -autoScaleX => ['PASSIVE', 'autoscalex', 'AutoScaleX', 'On'],
704             -autoScaleY1 => ['PASSIVE', 'autoscaley1', 'AutoScaleY1', 'On'],
705             -showError => ['PASSIVE', 'showError', 'ShowError', 1],
706             -maxPoints => ['PASSIVE', 'maxPoints', 'MaxPoints', 20],
707             -logMin => ['PASSIVE', 'logMin', 'LogMin', 0.001],
708             -redraw => ['PASSIVE', 'redraw', 'Redraw', undef],
709             -zoomButton => ['PASSIVE', 'zoomButton', 'ZoomButton', 1]
710             );
711              
712             $self -> SUPER::Populate($args);
713              
714             #helvetica Bookman Schumacher
715             # The four fonts are axis ticks[0], axis lables[1], plot title[2], and legend[3]
716             $self -> {-logCheck} = 0; # false, don't need to check on range of log data
717             # OK, setup the dataSets list
718             $self -> {-datasets} = []; # empty array, will be added to
719             $self -> {-zoomStack} = []; # empty array which will get the zoom stack
720              
721             # Some bindings here
722             # Add ballon help for the data points...
723             my $parent = $self -> parent; # ANDY
724             $self -> {Balloon} = $parent -> Balloon;
725             $self -> {BalloonPoints} = {};
726             $self -> {Balloon}
727             -> attach($self, -balloonposition => 'mouse', -msg => $self -> {BalloonPoints});
728              
729             # Must use Tk:: here to avoid calling the canvas::bind method
730             $self -> Tk::bind('' => [\&_resize]);
731              
732             return (1);
733             } # end Populate
734              
735             # When using the inherited configure method, array items cause
736             # memory leaks, so these will be handled by this method instead.
737             sub configure ## no critic (RequireFinalReturn) - Does not recognise return statement at end of method
738             {
739             my ($self, %args) = @_;
740              
741             foreach my $array_item (qw/-scale -xTickLabel -yTickLabel -y1TickLabel
742             -border -zoom -plotTitle -fonts -colors -legendPos/)
743             {
744             if (my $value = delete $args{$array_item})
745             {
746             $self -> {'Configure'}{$array_item} = $value;
747             }
748             }
749              
750             if (my $value = delete $args{-zoomButton})
751             {
752             $self -> _set_zoom_button($value);
753             }
754              
755             if (my @args = %args)
756             {
757             return ($self -> SUPER::configure(@args));
758             }
759              
760             return (1);
761             }
762              
763             sub _resize # called when the window changes size (configured)
764             {
765             my ($self) = @_; # This is the canvas (Plot)
766              
767             my $w = $self -> width; # Get the current size
768             my $h = $self -> height;
769             # print "_resize: mw size is ($h, $w)\n";
770             $self -> _rescale;
771              
772             return (1);
773             }
774              
775             sub _rescale # all, active, not
776             {
777             # _rescale the plot and redraw. Scale to all or just active as per argument
778             my ($self, $how, %args) = @_;
779             $self -> delete('all'); # empty the canvas, erase
780             $self -> _scale_plot($how) if (defined($how) and $how ne 'not'); # Get max and min for scalling
781             $self -> _draw_axis; # both x and y for now
782             $self -> _titles;
783             $self -> _draw_datasets(%args);
784             $self -> _legends(%args);
785             $self -> _call_redraw_callback;
786              
787             return (1);
788             }
789              
790             sub _call_redraw_callback
791             {
792             my ($self) = @_;
793             if (my $callback = $self -> cget(-redraw))
794             {
795             $callback = [$callback] if (ref($callback) eq 'CODE');
796             die "You must pass a list reference when using -redraw.\n"
797             unless ref($callback) eq 'ARRAY';
798             my ($sub, @args) = @$callback;
799             die "The array passed with the -redraw option must have a code reference as it's first element.\n"
800             unless ref($sub) eq 'CODE';
801             &$sub($self, @args);
802             }
803             return (1);
804             }
805              
806             sub _set_zoom_button
807             {
808             my ($self, $new_button) = @_;
809              
810             my $current_button = $self -> cget(-zoomButton);
811              
812             # Remove current bindings if any exist
813             if (defined($current_button) and $current_button =~ m/^[1-5]$/)
814             {
815             $self -> Tk::bind('', undef);
816             $self -> Tk::bind('', undef);
817             $self -> Tk::bind('', undef);
818             }
819              
820             # Apply new bindings if value is a valid mouse button
821             if ($new_button =~ m/^[1-5]$/)
822             {
823             $self -> Tk::bind('', [\&_zoom, 0]);
824             $self -> Tk::bind('', [\&_zoom, 1]);
825             $self -> Tk::bind('', [\&_zoom, 2]);
826             }
827              
828             # Set -zoomButton option in object
829             $self -> {'Configure'}{-zoomButton} = $new_button;
830              
831             return (1);
832             }
833              
834             sub _zoom
835             {
836             # start to do the zoom
837             my ($self, $which) = @_;
838             my $z;
839             # print "_zoom: which is <$which> self <$self> \n"if ($which == 1 or $which == 3);
840             if ($which == 0) # button 1 down
841             {
842             my $e = $self -> XEvent;
843             $z = $self -> cget('-zoom');
844             $z -> [0] = $e -> x; $z -> [1] = $e -> y;
845             $self -> configure('-zoom' => $z);
846             }
847             elsif ($which == 1) # button 1 release, that is do zoom
848             {
849             my $e = $self -> XEvent;
850             $z = $self -> cget('-zoom');
851             $z -> [2] = $e -> x; $z -> [3] = $e -> y;
852             $self -> configure('-zoom' => $z);
853             # OK, we can now do the zoom
854             # print "_zoom: $z -> [0], $z -> [1] $z -> [2], $z -> [3] \n";
855              
856             # If the box is small we undo one level of zoom
857             if ((abs($z -> [0]-$z -> [2]) < 3) and (abs($z -> [1]-$z -> [3]) < 3))
858             {
859             # try to undo one level of zoom
860             if (@{$self -> {'-zoomStack'}} == 0) # no zooms to undo
861             {
862             $z = $self -> cget('-zoom');
863             $self -> delete($z -> [4])if ($z -> [4] != 0);
864             return;
865             }
866              
867             my $s = pop(@{$self -> {'-zoomStack'}});
868             # print "_zoom: off stack $s -> [3], $s -> [4] \n";
869             $self -> configure(-scale => $s);
870             if ($self -> cget('-xType') eq 'log')
871             {
872             my ($aa, $bb) = (10**$s -> [0], 10**$s -> [1]);
873             # print "_zoom: a $aa b $bb \n";
874             my ($x_min_p, $x_max_p, $x_intervals, $tick_labels) = $self -> _log_range
875             (
876             $aa, $bb,
877             -tickFormat => $self -> cget('-xTickFormat')
878             );
879             # print "_zoom: $tick_labels \n";
880             $self -> configure(-xTickLabel => $tick_labels);
881             }
882             if ($self -> cget('-yType') eq 'log')
883             {
884             my ($aa, $bb) = (10**$s -> [3], 10**$s -> [4]);
885             # print "_zoom: a $aa b $bb \n";
886             my ($y_min_p, $y_max_p, $y_intervals, $tick_labels) = $self -> _log_range
887             (
888             $aa, $bb,
889             -tickFormat => $self -> cget('-yTickFormat')
890             );
891             # print "_zoom: $tick_labels \n";
892             $self -> configure(-yTickLabel => $tick_labels);
893             }
894             if ($self -> cget('-y1Type') eq 'log')
895             {
896             my ($aa, $bb) = (10**$s -> [6], 10**$s -> [7]);
897             # print "_zoom: for y1 log $aa b $bb \n";
898             my ($y_min_p, $y_max_p, $y_intervals, $tick_labels) = $self -> _log_range
899             (
900             $aa, $bb,
901             -tickFormat => $self -> cget('-y1TickFormat')
902             );
903             # print "_zoom: y1 $tick_labels \n";
904             $self -> configure(-y1TickLabel => $tick_labels);
905             }
906             }
907             else # box not small, time to zoom
908             {
909             my ($x1w, $y1w, $y11w) = $self -> _to_world_points($z -> [0], $z -> [1]);
910             my ($x2w, $y2w, $y12w) = $self -> _to_world_points($z -> [2], $z -> [3]);
911             my $z; #holdem
912             if ($x1w > $x2w)
913             {
914             $z = $x1w;
915             $x1w = $x2w;
916             $x2w = $z;
917             }
918             if ($y1w > $y2w)
919             {
920             $z = $y1w;
921             $y1w = $y2w;
922             $y2w = $z;
923             }
924             if ($y11w > $y12w)
925             {
926             $z = $y11w;
927             $y11w = $y12w;
928             $y12w = $z;
929             }
930              
931             # We've had trouble with extreme zooms, so trap that here...
932             if (($x2w - $x1w < 1e-12) or ($y2w - $y1w < 1e-12) or ($y12w - $y11w < 1e-12))
933             {
934             $z = $self -> cget('-zoom');
935             $self -> delete($z -> [4]) if ($z -> [4] != 0);
936             return;
937             }
938              
939             # push the old scale values on the zoom stack
940             push(@{$self -> {'-zoomStack'}}, $self -> cget(-scale));
941             # now _rescale
942             # print "_zoom: Rescale ($y1w, $y2w) ($x1w, $x2w) \n";
943             my ($y_min_p, $y_max_p, $y_intervals) = _nice_range($y1w, $y2w);
944             my ($y1min_p, $y1max_p, $y1intervals) = _nice_range($y11w, $y12w);
945             my ($x_min_p, $x_max_p, $x_intervals) = _nice_range($x1w, $x2w);
946             my ($x_tick_labels, $y_tick_labels, $y1_tick_labels);
947             if ($self -> cget('-xType') eq 'log')
948             {
949             ($x_min_p, $x_max_p, $x_intervals, $x_tick_labels) = $self -> _log_range
950             (
951             $x1w, $x2w,
952             -tickFormat => $self -> cget('-xTickFormat')
953             );
954             }
955             if ($self -> cget('-yType') eq 'log')
956             {
957             ($y_min_p, $y_max_p, $y_intervals, $y_tick_labels) = $self -> _log_range
958             (
959             $y1w, $y2w,
960             -tickFormat => $self -> cget('-yTickFormat')
961             );
962             }
963             if ($self -> cget('-y1Type') eq 'log')
964             {
965             ($y1min_p, $y1max_p, $y1intervals, $y1_tick_labels) = $self -> _log_range
966             (
967             $y11w, $y12w,
968             -tickFormat => $self -> cget('-y1TickFormat')
969             );
970             }
971              
972             # Swap minimum and maximum values if their axis has been reversed
973             my $curr_scale = $self -> cget(-scale);
974             ($x_min_p, $x_max_p) = ($x_max_p, $x_min_p) if ($$curr_scale[0] > $$curr_scale[1]);
975             ($y_min_p, $y_max_p) = ($y_max_p, $y_min_p) if ($$curr_scale[3] > $$curr_scale[4]);
976             ($y1min_p, $y1max_p) = ($y1max_p, $y1min_p) if ($$curr_scale[6] > $$curr_scale[7]);
977              
978             # print "_zoom: ($x_min_p, $x_max_p, $x_intervals) xTickLabels <$x_tick_labels> \n";
979             $self -> configure(-xTickLabel => $x_tick_labels);
980             $self -> configure(-yTickLabel => $y_tick_labels);
981             # print "($x_min_p, $x_max_p, $x_intervals), ($y_min_p, $y_max_p, $y_intervals), ($y1min_p, $y1max_p, $y1intervals)\n";
982             $self -> configure
983             (
984             -scale =>
985             [
986             $x_min_p, $x_max_p, $x_intervals,
987             $y_min_p, $y_max_p, $y_intervals,
988             $y1min_p, $y1max_p, $y1intervals
989             ]
990             );
991             }
992              
993             $self -> delete('all');
994             # draw again
995             $self -> _draw_axis; # both x and y for now
996             $self -> _titles;
997             $self -> _draw_datasets;
998             $self -> _legends;
999             $self -> _call_redraw_callback;
1000             }
1001             elsif ($which == 2) # motion, draw box
1002             {
1003             my $e = $self -> XEvent;
1004             $z = $self -> cget('-zoom');
1005             $self -> delete($z -> [4])if ($z -> [4] != 0);
1006             $z -> [4] = $self
1007             -> createRectangle($z -> [0], $z -> [1], $e -> x, $e -> y, '-outline' => 'gray');
1008             $self -> configure('-zoom' => $z);
1009             }
1010             return (1);
1011             }
1012              
1013             sub _create_plot_axis # start and end point of the axis, other args a => b
1014             {
1015             # Optional args -tick
1016             # Optional args -label
1017             # An array containing colour, font and a list of text to display next to
1018             # each tick.
1019             # Optional args -tickFormat
1020             # The sprintf format to use if -label is not provided.
1021             #
1022             # end points are in Canvas pixels
1023             my ($self, $x1, $y1, $x2, $y2, %args) = @_;
1024             my $y_axis = 0;
1025             if ($x1 == $x2)
1026             {
1027             $y_axis = 1;
1028             }
1029             elsif ($y1 != $y2)
1030             {
1031             die 'Cannot determine if X or Y axis desired.'
1032             }
1033              
1034             my $tick = delete $args{-tick};
1035             my $label = delete $args{-label};
1036             my $tick_format = delete $args{-tickFormat};
1037             $tick_format = '%.3g' unless $tick_format;
1038             my ($do_tick, $do_label) = map {ref $_ eq 'ARRAY'} ($tick, $label);
1039              
1040             $self -> createLine($x1, $y1, $x2, $y2, %args);
1041              
1042             if ($do_tick)
1043             {
1044             my ($tcolor, $tfont, $side, $start, $stop, $incr, $delta, $type) = @$tick;
1045             # start, stop are in the world system
1046             # $incr is space between ticks in world coordinates $delta is the number of pixels between ticks
1047             # If type is log then a log axis maybe not
1048             my ($lcolor, $lfont, @labels);
1049             ($lcolor, $lfont, @labels) = @$label if $do_label;
1050             # print "t font <$tfont> l font <$lfont> \n";
1051             my $l;
1052             my $z = 0; # will get $delta added to it, not x direction!
1053             my $tl;
1054             my $an;
1055             if ($y_axis)
1056             {
1057             $tl = $side eq 'w' ? 5 : -6; # tick length
1058             $an = $side eq 'w' ? 'e' : 'w' if $y_axis; #anchor
1059             }
1060             else
1061             {
1062             $tl = $side eq 's' ? 5 : -6; # tick length
1063             $an = $side eq 's' ? 'n' : 's' if not $y_axis;
1064             }
1065             # do the ticks
1066             $incr = 1 if (abs($stop - $start) < 1e-15); # AC: Rounding errors can cause an infinite loop when range is zero!
1067             # This line above fixes this by detecting this case and fixing the increment to 1. (Of course, range should not be zero anyway!)
1068             # print "ticks for loop $l = $start; $l <= $stop; $l += $incr\n"; # DEBUG
1069             for
1070             (
1071             my $l = $start;
1072             ($start <= $stop) ? ($l <= $stop) : ($l >= $stop);
1073             ($start <= $stop) ? ($l += $incr) : ($l -= $incr)
1074             )
1075             {
1076             if ($y_axis)
1077             {
1078             $self -> createLine
1079             (
1080             $x1 - $tl, $y2 - $z, $x1, $y2 - $z,
1081             %args, -fill => $tcolor,
1082             );
1083             }
1084             else
1085             {
1086             $self -> createLine
1087             (
1088             $z + $x1, $y1 + $tl, $z + $x1, $y2,
1089             %args, -fill => $tcolor,
1090             );
1091             }
1092             if ($do_label)
1093             {
1094             my $lbl = shift(@labels);
1095             if ($y_axis)
1096             {
1097             $self -> createText
1098             (
1099             $x1 - $tl, $y2 - $z, -text => $lbl,
1100             %args, -fill => $lcolor,
1101             -font => $lfont, -anchor => $an,
1102             ) if $lbl;
1103             }
1104             else
1105             {
1106             $self -> createText
1107             (
1108             $z + $x1, $y1 + $tl, -text => $lbl,
1109             %args, -fill => $lcolor,
1110             -font => $lfont, -anchor => $an,
1111             ) if $lbl;
1112             }
1113             }
1114             else # default label uses tfont
1115             {
1116             $l = 0 if (($l < 1e-15) and ($l > -1e-15)); # Fix rounding errors at zero.
1117             if ($y_axis)
1118             {
1119             $self -> createText
1120             (
1121             $x1 - $tl, $y2 - $z, -text => sprintf($tick_format, $l),
1122             %args, -fill => $tcolor,
1123             -font => $tfont, -anchor => $an,
1124             );
1125             }
1126             else
1127             {
1128             $self -> createText
1129             (
1130             $z + $x1, $y1 + $tl, -text => sprintf($tick_format, $l),
1131             %args, -fill => $tcolor,
1132             -font => $tfont, -anchor => $an,
1133             );
1134             }
1135             }
1136             ($start <= $stop) ? ($z += $delta) : ($z -= $delta); # only use of delta
1137             }
1138             } # ifend label this axis
1139              
1140             return (1);
1141             } # end _create_plot_axis
1142              
1143             sub _titles
1144             {
1145             # put axis titles and plot title on the plot
1146             # x, y, y1, plot all at once for now
1147             my ($self) = @_;
1148             my $borders = $self -> cget(-border);
1149             my $fonts = $self -> cget('-fonts');
1150             my $w = $self -> width;
1151             my $h = $self -> height;
1152             # y axis
1153             my $y_label = $self -> cget('-ylabel');
1154             my $y_label_pos = $self -> cget('-ylabelPos');
1155             my $y_start = $self -> _center_text_v($borders -> [0], $h - $borders -> [2], $fonts -> [1], $y_label);
1156             $self -> _create_text_v
1157             (
1158             $self -> _to_canvas_pixels('canvas', $borders -> [3] - $y_label_pos, $h - $y_start),
1159             -text => $y_label, -anchor => 's', -font => $fonts -> [1], -tag => 'aaaaa',
1160             );
1161              
1162             # Is y1 axis used for active datasets?
1163              
1164             # y1 axis
1165             my $y1label = $self -> cget('-y1label');
1166             my $y1label_pos = $self -> cget('-y1labelPos');
1167             my $y1start = $self -> _center_text_v($borders -> [0], $h - $borders -> [2], $fonts -> [1], $y1label);
1168             $self -> _create_text_v
1169             (
1170             $self -> _to_canvas_pixels('canvas', $w - $borders -> [1] + $y1label_pos, $h - $y1start),
1171             -text => $y1label, -anchor => 'sw', -font => $fonts -> [1], -tag => 'y1y1y1y1'
1172             ) if ($self -> _count_y1);
1173              
1174             # x axis
1175             my $x_label = $self -> cget('-xlabel');
1176             my $x_label_pos = $self -> cget('-xlabelPos');
1177             my $x_start = $self -> _center_text($borders -> [3], $w - $borders -> [1], $fonts -> [1], $x_label);
1178             $self -> createText
1179             (
1180             $self -> _to_canvas_pixels('canvas', $x_start, $borders -> [2] - $x_label_pos),
1181             -text => $x_label, -anchor => 'sw', -font => $fonts -> [1]
1182             );
1183              
1184             # add a plot title
1185             my $title = $self -> cget('-plotTitle');
1186             $x_start = $self -> _center_text($borders -> [3], $w - $borders -> [1], $fonts -> [2], $title -> [0]);
1187             $self -> createText
1188             (
1189             $self -> _to_canvas_pixels('canvas', $x_start, $h - $borders -> [0] + $title -> [1]),
1190             text => $title -> [0], -anchor => 'nw', -font => $fonts -> [2], -tags => ['title']
1191             );
1192             return (1);
1193             }
1194              
1195             sub _create_text_v # canvas widget, x, y, then all the text arguments plus -scale => number
1196             {
1197             # Writes text from top to bottom.
1198             # For now argument -anchor is removed
1199             # scale is set to 0.75. It the fraction of the previous letter's height that the
1200             # current letter is lowered.
1201             my ($self, $x, $y, %args) = @_;
1202             my $text = delete($args{-text});
1203             my $anchor = delete($args{-anchor});
1204             my $tag = delete($args{-tag});
1205             my @letters = split(//, $text);
1206             # print "args", %args, "\n";;
1207             # OK we know that we have some short and some long letters
1208             # a, c, e, g, m, m, o, p, r, s, t, u, v, w, x, y, z are all short. They could be moved up a tad
1209             # also g, j, q, and y hang down, the next letter has to be lower
1210             my $th = 0;
1211             my $lc = 0;
1212              
1213             my ($font_width) = $self -> fontMeasure($args{-font}, 'M'); # Measure a wide character to determine the x offset
1214             $x -= $font_width if $anchor =~ /w/; # AC: Implement missing functionality!
1215              
1216             # sorry to say, the height of all the letters as returned by bbox is the same for a given font.
1217             # same is true for the text widget. Nov 2005!
1218             my $letter = shift(@letters);
1219             $self -> createText($x, $y + $th, -text => $letter, -tags => [$tag], %args, -anchor => 'c'); # first letter
1220             my ($min_x, $min_y, $max_x, $max_y) = $self -> bbox($tag);
1221             my $h = $max_y - $min_y;
1222             my $w = $max_x - $min_x;
1223             my $step = 0.80;
1224             $th = $step * $h + $th;
1225             foreach my $letter (@letters)
1226             {
1227             # print "_create_text_v: letter <$letter>\n";
1228             # If the letter is short, move it up a bit.
1229             $th = $th - 0.10 * $h if ($letter =~ /[acegmnoprstuvwxyz.;, :]/); # move up a little
1230             $th = $th - 0.40 * $h if ($letter =~ /[ ]/); # move up a lot
1231             # now write the letter
1232             $self -> createText($x, $y + $th, -text => $letter, -tags => [$tag], %args, -anchor => 'c');
1233             # space for the next letter
1234             $th = $step * $h + $th;
1235             $th = $th + 0.10 * $h if ($letter =~ /[gjpqy.]/); # move down a bit if the letter hangs down
1236             $lc++;
1237             }
1238             return (1);
1239             }
1240              
1241             sub _legends
1242             {
1243             # For all the (active) plots, put a legend
1244             my ($self, %args) = @_;
1245             my $count = 0;
1246             # count the (active) data sets
1247             foreach my $ds (@{$self -> {-datasets}})
1248             {
1249             unless ($ds -> get(-noLegend))
1250             {
1251             $count++ if ($ds -> get('-active') == 1);
1252             }
1253             }
1254             # print "_legends have $count legends to do\n";
1255             my $fonts = $self -> cget('-fonts');
1256              
1257             # Calculate the starting point
1258             my $x_start = 0;
1259             my $y_start = 0;
1260             my $legend_info = $self -> cget('-legendPos');
1261             my $borders = $self -> cget('-border');
1262             if (not defined($legend_info) or $legend_info -> [0] eq 'bottom')
1263             {
1264             $x_start = $borders -> [3];
1265             $y_start = $borders -> [2] - $legend_info -> [1];
1266             }
1267             elsif ($legend_info -> [0] eq 'side')
1268             {
1269             # Find out how big text is
1270             my $test_tag = 'dfjcnjdbnc';
1271             $self -> createText
1272             (
1273             0, 10_000, -text => 'test', -anchor => 'sw', -fill => 'black',
1274             -font => $fonts -> [3], -tags => [$test_tag]
1275             );
1276             my ($text_min_x, $text_min_y, $text_max_x, $text_max_y) = $self -> bbox($test_tag);
1277             my $text_height = $text_max_y - $text_min_y;
1278             $self -> delete($test_tag);
1279              
1280             $x_start = $self -> width - $borders -> [1] + $legend_info -> [1];
1281             $y_start = $self -> height - $borders -> [0] - $text_height;
1282             }
1283             else
1284             {
1285             warn 'Legend position ' . $legend_info -> [0] . "is not valid\n";
1286             }
1287              
1288             my $x_pos = $x_start;
1289             my $y_pos = $y_start;
1290             foreach my $ds (@{$self -> {-datasets}})
1291             {
1292             unless ($ds -> get(-noLegend))
1293             {
1294             if ($ds -> get('-active') != 99) # do them all, not just active
1295             {
1296             my ($x, $y) = $self -> _to_canvas_pixels('canvas', $x_pos, $y_pos);
1297             my $line_tag = $ds -> get('-name');
1298             my $point_tag = $line_tag.'point';
1299             my $tag = $line_tag . 'legend';
1300              
1301             my $fill = $ds -> get('-color');
1302             my $fill_point = $ds -> get('-fillPoint');
1303             my $point_style = $ds -> get('-pointStyle');
1304             my $point_size = $ds -> get('-pointSize');
1305             my $dash = $ds -> get('-dash');
1306             my $text = $ds -> get('-name');
1307              
1308             my $no_line = 0;
1309             if (defined $ds -> get('-lineStyle'))
1310             {
1311             if ($ds -> get('-lineStyle') eq 'none')
1312             {
1313             $no_line = 1;
1314             }
1315             }
1316              
1317             $text = ($ds -> get('-yAxis') eq 'Y1') ? $text . '(Y1) ' : $text . ' ';
1318              
1319             my ($textX, $textY) = $self -> _to_canvas_pixels('canvas', $x_pos + 50, $y_pos);
1320             $self -> createText
1321             (
1322             $textX, $textY,
1323             -text => $text, -anchor => 'sw', -fill => $ds->get('-color'),
1324             -font => $fonts -> [3], -tags => [$tag]
1325             );
1326              
1327             # Find out how big text is
1328             my ($text_min_x, $text_min_y, $text_max_x, $text_max_y) = $self -> bbox($tag);
1329             my $text_height = $text_max_y - $text_min_y;
1330              
1331             # Print line if necessery
1332             if (!$no_line)
1333             {
1334             $self -> createLine
1335             (
1336             $x, $y - $text_height / 2, $x + 40, $y - $text_height / 2, -fill => $fill,
1337             -dash => $dash, -tags => [$tag]
1338             );
1339             }
1340             $self -> _draw_point
1341             (
1342             $x + 20, $y - $text_height / 2, 0, 0,
1343             -fill => $fill, -pointStyle => $point_style, -pointSize => $point_size,
1344             -fillPoint => $fill_point, -tags => [$tag, $point_tag]
1345             );
1346              
1347             # If multiple curves, turn the line and the plot name red when we enter it with the cursor in the legend
1348             if (scalar(@{$self -> {-datasets}}) > 1)
1349             {
1350             $self -> bind
1351             (
1352             $tag, '' => sub
1353             {
1354             # print "Highlighting <$line_tag> and <$tag>.\n";
1355             $self -> itemconfigure($point_tag, -fill => 'red');
1356             $self -> itemconfigure($line_tag, -fill => 'red');
1357             $self -> itemconfigure($tag, -fill => 'red');
1358             }
1359             );
1360             $self -> bind
1361             (
1362             $tag, '' => sub
1363             {
1364             $self -> itemconfigure($line_tag, -fill => $fill);
1365             $self -> itemconfigure($tag, -fill => $fill);
1366             if ($fill_point)
1367             {
1368             $self -> itemconfigure($point_tag, -fill => $fill);
1369             }
1370             else
1371             {
1372             $self -> itemconfigure($point_tag, -fill => '');
1373             }
1374             }
1375             );
1376             }
1377             my ($x1, $y1, $x2, $y2) = $self -> bbox($tag);
1378             if (not defined($legend_info) or $legend_info -> [0] eq 'bottom')
1379             {
1380             if ($x2)
1381             {
1382             $x_pos = $x2 + 10;
1383             if ($y2)
1384             {
1385             # Wrap legend items if they are too wide to fit on the current line
1386             if ($x_pos + ($x2 - $x1) >= $self -> width)
1387             {
1388             $x_pos = $x_start;
1389             $y_pos = $y_pos - ($y2 - $y1);
1390             }
1391             }
1392             }
1393             else
1394             {
1395             $x_pos += 100;
1396             }
1397             }
1398             else
1399             {
1400             if ($y2)
1401             {
1402             $y_pos -= ($y2 - $y1) + 10;
1403             }
1404             else
1405             {
1406             $y_pos -= 100;
1407             }
1408             }
1409             # print "_legends location of last character p1($x1, $y1), p2($x2, $y2)\n";
1410             }
1411             }
1412             }
1413             return (1);
1414             }
1415              
1416             sub addDatasets ## no critic (NamingConventions::ProhibitMixedCaseSubs)
1417             {
1418             # add data sets to the plot object
1419             my ($self, @datasets) = @_;
1420             foreach my $dataset (@datasets)
1421             {
1422             unless (ref($dataset) eq 'LineGraphDataset')
1423             {
1424             warn 'addDatasets: Dataset must be a Tk::LineGraphDataset object'
1425             }
1426             else
1427             {
1428             push @{$self -> {-datasets}}, $dataset;
1429             }
1430             }
1431             return (1);
1432             }
1433              
1434             sub clearDatasets ## no critic (NamingConventions::ProhibitMixedCaseSubs)
1435             {
1436             # removes all data sets from the plot object
1437             my ($self) = @_;
1438             @{$self -> {-datasets}} = ();
1439             return (1);
1440             }
1441              
1442             sub _count_y1
1443             {
1444             # count how many datasets are using y1
1445             my ($self) = @_;
1446             my $count = 0;
1447             foreach my $ds (@{$self -> {-datasets}})
1448             {
1449             $count++ if ($ds -> get('-yAxis') eq 'Y1');
1450             }
1451             # print "_count_y1 <$count>\n";
1452             return ($count);
1453             }
1454              
1455             sub _data_sets_min_max # one argument, all or active
1456             {
1457             # Get the min and max of the datasets
1458             # could be done for all datasets or just the active datasets
1459             # return xmin, xmax, ymin, ymax, y1min, y1max
1460             my ($self, $rescale) = @_;
1461             my $all = 0;
1462             $all = 1 if ($rescale and $rescale eq 'all');
1463             my ($first, $first1) = (0, 0);
1464             my ($y_max, $y_min, $x_max, $x_min, $y_max1, $y_min1) = (0, 0, 0, 0, 0, 0);
1465             my ($x_data, $y_data, $y_error);
1466             # Do x then y and y1
1467             foreach my $ds (@{$self -> {-datasets}})
1468             {
1469             if ($all or ($ds -> get('-active') == 1))
1470             {
1471             $y_data = $ds -> get('-yData');
1472             $x_data = $ds -> get('-xData');
1473             $x_data = [0..scalar(@$y_data) - 1] unless (defined($x_data));
1474             if ($first == 0)
1475             {
1476             $x_max = $x_min = $x_data -> [0];
1477             $first = 1;
1478             }
1479             foreach my $e (@{$x_data})
1480             {
1481             $x_max = $e if ($e > $x_max );
1482             $x_min = $e if ($e < $x_min );
1483             }
1484             }
1485             }
1486             $first = $first1 = 0;
1487             foreach my $ds (@{$self -> {-datasets}})
1488             {
1489             if ($all or ($ds -> get('-active') == 1))
1490             {
1491             my $a = 0;
1492              
1493             $y_data = $ds -> get('-yData');
1494             $y_error = $ds -> get('-yError');
1495              
1496             if ($ds -> get('-yAxis') eq 'Y1')
1497             {
1498             if ($first1 == 0)
1499             {
1500             $y_max1 = $y_min1 = $y_data -> [0];
1501             $first1 = 1;
1502             }
1503              
1504             foreach my $e (@{$y_data})
1505             {
1506             $y_max1 = $e if ($e > $y_max1);
1507             $y_min1 = $e if ($e < $y_min1);
1508              
1509             if ($y_error)
1510             {
1511             # Make all error values positive
1512             $y_max1 = $e + abs($y_error -> [$a]) if ($e + abs($y_error -> [$a]) > $y_max1);
1513             $y_min1 = $e - abs($y_error -> [$a]) if ($e - abs($y_error -> [$a]) < $y_min1);
1514             $a++;
1515             }
1516             }
1517             }
1518             else
1519             { # for y axis
1520             if ($first == 0)
1521             {
1522             $y_max = $y_min = $y_data -> [0];
1523             $first = 1;
1524             }
1525              
1526             foreach my $e (@{$y_data})
1527             {
1528             $y_max = $e if ($e > $y_max);
1529             $y_min = $e if ($e < $y_min);
1530              
1531             if ($y_error)
1532             {
1533             # Make all error values positive
1534             $y_max = $e+abs($y_error->[$a]) if ($e+abs($y_error->[$a]) > $y_max);
1535             $y_min = $e-abs($y_error->[$a]) if ($e-abs($y_error->[$a]) < $y_min);
1536             $a++;
1537             }
1538             }
1539             }
1540             }
1541             }
1542             # print "_data_sets_min_max: X($x_min, $x_max), Y($y_min, $y_max), Y1($y_min1, $y_max1)\n";
1543             return ($x_min, $x_max, $y_min, $y_max, $y_min1, $y_max1);
1544             }
1545              
1546             sub _scale_plot # 'all' or 'active'
1547             {
1548             # scale either all the data sets or just the active ones
1549             my ($self, $how) = @_;
1550             my ($x_min, $x_max, $y_min, $y_max, $y1min, $y1max) = $self -> _data_sets_min_max($how);
1551             # print "_scale_plot: min and max ($x_min, $x_max), ($y_min, $y_max), ($y1min, $y1max)\n";
1552             my ($x_tick_labels, $y_tick_labels, $y1_tick_labels);
1553             my ($y_min_p, $y_max_p, $y_intervals);
1554             my $scale = $self -> cget(-scale);
1555             if ($self -> cget(-autoScaleY) eq 'On')
1556             {
1557             ($y_min_p, $y_max_p, $y_intervals) = _nice_range($y_min, $y_max);
1558             if ($self -> cget('-yType') eq 'log')
1559             {
1560             ($y_min_p, $y_max_p, $y_intervals, $y_tick_labels) = $self -> _log_range
1561             (
1562             $y_min, $y_max,
1563             -tickFormat => $self -> cget('-yTickFormat')
1564             );
1565             }
1566             }
1567             else
1568             {
1569             ($y_min_p, $y_max_p, $y_intervals) = ($scale -> [3], $scale -> [4], $scale -> [5]);
1570             }
1571             my ($y1min_p, $y1max_p, $y1intervals);
1572             if ($self -> cget(-autoScaleY1) eq 'On')
1573             {
1574             ($y1min_p, $y1max_p, $y1intervals) = _nice_range($y1min, $y1max);
1575             if ($self -> cget('-y1Type') eq 'log')
1576             {
1577             ($y1min_p, $y1max_p, $y1intervals, $y1_tick_labels) = $self -> _log_range
1578             (
1579             $y1min, $y1max,
1580             -tickFormat => $self -> cget('-y1TickFormat')
1581             );
1582             }
1583             }
1584             else
1585             {
1586             ($y1min_p, $y1max_p, $y1intervals) = ($scale -> [6], $scale -> [7], $scale -> [8]);
1587             }
1588             my ($x_min_p, $x_max_p, $x_intervals);
1589             if ($self -> cget(-autoScaleX) eq 'On')
1590             {
1591             ($x_min_p, $x_max_p, $x_intervals) = _nice_range($x_min, $x_max);
1592             if ($self -> cget('-xType') eq 'log')
1593             {
1594             ($x_min_p, $x_max_p, $x_intervals, $x_tick_labels) = $self -> _log_range
1595             (
1596             $x_min, $x_max,
1597             -tickFormat => $self -> cget('-xTickFormat')
1598             );
1599             }
1600             }
1601             else
1602             {
1603             ($x_min_p, $x_max_p, $x_intervals) = ($scale -> [0], $scale -> [1], $scale -> [2]);
1604             }
1605             # print "_scale_plot: $y_min_p, $y_max_p, $y_intervals, @$y_tick_labels\n";
1606             # print "($x_min_p, $x_max_p, $x_intervals) tickLabels <$x_tick_labels> \n";
1607             $self -> configure(-xTickLabel => $x_tick_labels);
1608             $self -> configure(-yTickLabel => $y_tick_labels);
1609             $self -> configure(-y1TickLabel => $y1_tick_labels);
1610             # print "_scale_plot: Y $y_min_p, $y_max_p, $y_intervals X $x_min_p, $x_max_p, $x_intervals \n";
1611             # put these scale values into the plot widget
1612             $self -> configure
1613             (
1614             -scale =>
1615             [
1616             $x_min_p, $x_max_p, $x_intervals,
1617             $y_min_p, $y_max_p, $y_intervals,
1618             $y1min_p, $y1max_p, $y1intervals
1619             ]
1620             );
1621             # print "in scale $y_min_p, $y_max_p, $y_intervals \n";
1622             # reset the zoom stack!
1623             $self -> {-zoomStack} = [];
1624             return (1);
1625             }
1626              
1627             sub plot
1628             {
1629             # plot all the active data sets
1630             # 'always' (Default), 'never' or 'not_zoomed'
1631             my ($self, $rescale) = @_;
1632             $rescale = 'always' unless defined($rescale); # Default to Always
1633              
1634             if ($rescale eq 'always') # Always Rescale
1635             {
1636             $self -> _rescale('all');
1637             }
1638             elsif ($rescale eq 'never') # Never Rescale
1639             {
1640             $self -> _rescale('not');
1641             }
1642             elsif ($rescale eq 'not_zoomed') # Only Rescale if not Zoomed in
1643             {
1644             if (@{$self -> {-zoomStack}} == 0)
1645             {
1646             $self -> _rescale('all');
1647             }
1648             else
1649             {
1650             $self -> _rescale('not');
1651             }
1652             }
1653              
1654             return (1);
1655             }
1656              
1657             sub _draw_axis
1658             {
1659             # do both of the axis
1660             my ($self) = @_;
1661             my $s = $self -> cget(-scale); # get the scale factors
1662             my ($nb, $eb, $sb, $wb) = @{$self -> cget(-border)};
1663             # for now, figure this will fit
1664             my $h = $self -> height;
1665             my $w = $self -> width;
1666             my $x_tick_label = $self -> cget('-xTickLabel');
1667             my $fonts = $self -> cget('-fonts');
1668             # print "_draw_axis: xTickLabel <$x_tick_label>\n";
1669             my $lab = [];
1670             if ($x_tick_label)
1671             {
1672             # print "draw axis: making tick labels\n";
1673             push (@{$lab}, 'black', $fonts -> [0]);
1674             foreach my $tl (@{$x_tick_label})
1675             {
1676             push @{$lab}, $tl;
1677             # print "_draw_axis: @{$lab} \n";
1678             }
1679             }
1680             else
1681             {
1682             $lab = undef;
1683             }
1684              
1685             # xAxis first
1686             # tick stuff
1687             my ($t_start, $t_stop, $interval) = ($s -> [0], $s -> [1], abs($s -> [2]));
1688             my $ticks = ($t_stop - $t_start) / $interval;
1689             my $a_length = $w - $wb - $eb;
1690             my $d = $a_length / $ticks;
1691             my ($x_start, $y_start, $x_end, $y_end) = ($wb, $h - $sb, $w - $eb, $h - $sb);
1692             my $result = $self -> _create_plot_axis
1693             (
1694             $x_start, $y_start, $x_end, $y_end,
1695             -fill => 'black',
1696             # $tcolor, $tfont, $side, $start, $stop, $incr, $delta)
1697             # incr step size - used in lable in PIXELS, delta is the PIXELS between ticks
1698             # have to start at the start of the "axis". Not good!
1699             -tick => ['black', $fonts -> [0], 's', $t_start, $t_stop, $interval, $d],
1700             -tickFormat => $self -> cget('-xTickFormat'),
1701             -label => $lab,
1702             );
1703              
1704             # box x axis
1705             ($x_start, $y_start, $x_end, $y_end) = ($wb, $nb, $w - $eb, $nb);
1706             $result = $self -> _create_plot_axis
1707             (
1708             $x_start, $y_start, $x_end, $y_end,
1709             -fill => 'black'
1710             );
1711              
1712             # setup the tick labels if they have been set
1713             my $y_tick_label = $self -> cget('-yTickLabel');
1714             $lab = [];
1715             if ($y_tick_label)
1716             {
1717             # print "_draw_axis: making tick labels for y\n";
1718             push @{$lab}, 'black', $fonts -> [0] ;
1719             foreach my $tl (@{$y_tick_label})
1720             {
1721             push @{$lab}, $tl;
1722             # print "_draw_axis: @{$lab} \n";
1723             }
1724             }
1725             else
1726             {
1727             $lab = undef;
1728             }
1729             # print "y axis label <$lab> \n";
1730             #YAxis now
1731             ($x_start, $y_start, $x_end, $y_end) = ($wb, $nb, $wb, $h-$sb);
1732             ($t_start, $t_stop, $interval) = ($s -> [3], $s -> [4], abs($s -> [5]));
1733             $interval = 10 if ($interval <= 0);
1734             $ticks = ($t_stop - $t_start) / $interval;
1735             $a_length = $h - $nb - $sb;
1736             $d = $a_length / $ticks;
1737             $result = $self -> _create_plot_axis
1738             (
1739             $x_start, $y_start, $x_end, $y_end,
1740             -fill => 'black',
1741             # $tcolor, $tfont, $side, $start, $stop, $incr, $delta)
1742             # incr step size - used in lable in PIXELS, delta is the PIXELS between ticks
1743             # have to start at the start of the "axis". Not good!
1744             -tickFormat => $self -> cget('-yTickFormat'),
1745             -tick => ['black', $fonts -> [0], 'w', $t_start, $t_stop, $interval, $d],
1746             -label => $lab,
1747             );
1748              
1749             #Y1Axis now if needed
1750             if ($self -> _count_y1)
1751             {
1752             # setup the tick labels if they have been set
1753             my $y1_tick_label = $self -> cget('-y1TickLabel');
1754             $lab = [];
1755             if ($y1_tick_label)
1756             {
1757             # print "_draw_axis: making tick labels for y\n";
1758             push (@{$lab}, 'black', $fonts -> [0]);
1759             foreach my $tl (@{$y1_tick_label})
1760             {
1761             push (@{$lab}, $tl);
1762             # print "_draw_axis: @{$lab} \n";
1763             }
1764             }
1765             else
1766             {
1767             $lab = undef;
1768             }
1769             ($x_start, $y_start, $x_end, $y_end) = ($w-$eb, $nb, $w-$eb, $h-$sb);
1770             ($t_start, $t_stop, $interval) = ($s -> [6], $s -> [7], abs($s -> [8]));
1771             $interval = 10 if ($interval <= 0);
1772             $ticks = ($t_stop - $t_start) / $interval;
1773             $a_length = $h - $nb - $sb;
1774             $d = ($ticks != 0) ? $a_length / $ticks : 1;
1775             $result = $self -> _create_plot_axis
1776             (
1777             $x_start, $y_start, $x_end, $y_end,
1778             -fill => 'black',
1779             # $tcolor, $tfont, $side, $start, $stop, $incr, $delta)
1780             # incr step size - used in lable in PIXELS, delta is the PIXELS between ticks
1781             # have to start at the start of the "axis". Not good!
1782             -tick => ['black', $fonts -> [0], 'e', $t_start, $t_stop, $interval, $d],
1783             -tickFormat => $self -> cget('-y1TickFormat'),
1784             -label => $lab,
1785             );
1786             }
1787             # box y axis
1788             ($x_start, $y_start, $x_end, $y_end) = ($w-$eb, $nb, $w-$eb, $h-$sb);
1789             $result = $self -> _create_plot_axis
1790             (
1791             $x_start, $y_start, $x_end, $y_end,
1792             -fill => 'black',
1793             );
1794             $self -> _log_ticks;
1795             return (1);
1796             }
1797              
1798             sub _log_ticks
1799             {
1800             # put the 2, 3, 4, ..., 9 ticks on a log axis
1801             my ($self) = @_;
1802             my $s = $self -> cget('-scale');
1803             my ($h, $w) = ($self -> height, $self -> width);
1804             my $borders = $self -> cget('-border');
1805             # do x axis
1806             if ($self -> cget('-xType') eq 'log')
1807             {
1808             my ($min_p, $max_p, $delta_p) = ($s -> [0], $s -> [1], $s -> [2]);
1809             my $dec = ($max_p - $min_p);
1810             unless ($dec > 5) # only if there are less than four decades
1811             {
1812             my $axis_length = $w - $borders -> [1] - $borders -> [3];
1813             my $d_length = $axis_length / ($max_p - $min_p);
1814             my $delta;
1815             my $y = $h - $borders -> [2];
1816             foreach my $ii (1..$dec)
1817             {
1818             foreach my $i (2..9)
1819             {
1820             my $delta = (log10 $i) * $d_length;
1821             my $x = ($borders -> [3]) + $delta + $d_length * ($ii - 1);
1822             # print "_log_ticks: $ii $i delta $delta y $y \n";
1823             $self -> createLine($x, $y, $x, $y + 6, -fill => 'black');
1824             }
1825             } # end each decade
1826             }
1827             }
1828             # do y axis
1829             if ($self -> cget('-yType') eq 'log')
1830             {
1831             my ($min_p, $max_p, $delta_p) = ($s -> [3], $s -> [4], $s -> [5]);
1832             my $dec = ($max_p - $min_p);
1833             unless ($dec > 5) # only if there are less than four decades
1834             {
1835             my $axis_length = $h - $borders -> [0] - $borders -> [2];
1836             my $d_length = $axis_length / ($max_p - $min_p);
1837             my $delta;
1838             foreach my $ii (1..$dec)
1839             {
1840             foreach my $i (2..9)
1841             {
1842             my $delta = (log10 $i) * $d_length;
1843             my $y = $h - ($borders -> [2]) - $delta - $d_length * ($ii - 1);;
1844             # print "_log_ticks: $ii $i delta $delta y $y \n";
1845             $self -> createLine($borders -> [3], $y, $borders -> [3] + 6, $y, -fill => 'black');
1846             }
1847             } # end each decade
1848             }
1849             }
1850             # do y1 axis
1851             if ($self -> cget('-y1Type') eq 'log')
1852             {
1853             my ($min_p, $max_p, $delta_p) = ($s -> [6], $s -> [7], $s -> [8]);
1854             my $dec = ($max_p - $min_p);
1855             unless ($dec > 5) # only if there are less than four decades
1856             {
1857             my $axis_length = $h - $borders -> [0] - $borders -> [2];
1858             my $d_length = $axis_length / ($max_p - $min_p);
1859             my $delta;
1860             foreach my $ii (1..$dec)
1861             {
1862             foreach my $i (2..9)
1863             {
1864             my $delta = (log10 $i) * $d_length;
1865             my $x = $self -> width - $borders -> [1];
1866             my $y = $h - ($borders -> [2]) - $delta - $d_length * ($ii - 1);
1867             # print "_log_ticks: $ii $i delta $delta y $y \n";
1868             $self -> createLine($x, $y, $x - 6, $y, -fill => 'black');
1869             }
1870             } # end each decade
1871             }
1872             }
1873             return (1);
1874             }
1875              
1876             sub _draw_datasets
1877             {
1878             # draw the line(s) for all active datasets
1879             my ($self, @args) = @_;
1880             %{$self -> {BalloonPoints}} = (); # Clear the balloon help hash before drawing.
1881             foreach my $ds (@{$self -> {-datasets}})
1882             {
1883             if ($ds -> get('-active') == 1)
1884             {
1885             $self -> _draw_one_dataset($ds);
1886             }
1887             }
1888             return (1);
1889             }
1890              
1891             sub _draw_one_dataset # index of the dataset to draw, widget args
1892             {
1893             # draw even if not active ?
1894             my ($self, $ds, %args) = @_;
1895             # %args seems not to be used here.
1896             my ($nb, $eb, $sb, $wb) = @{$self -> cget(-border)};
1897             my $tag = $ds -> get('-name');
1898             my $fill;
1899             my $index = $ds -> get('-index');
1900             if ($ds -> get('-color') eq 'none')
1901             {
1902             my $colors = $self -> cget(-colors);
1903             $fill = $self -> cget('-colors') -> [$index % @$colors];
1904             $ds -> set('-color' => $fill);
1905             }
1906             else
1907             {
1908             $fill = $ds -> get('-color');
1909             }
1910              
1911             my $line_style = $ds -> get('-lineStyle'); #SS - added option to set line style
1912             my $no_line = 0;
1913             my $dash = '';
1914             if ($line_style)
1915             {
1916             if ($line_style eq 'none')
1917             {
1918             $no_line = 1;
1919             }
1920             elsif ($line_style eq 'normal')
1921             {
1922             $dash = '';
1923             }
1924             elsif ($line_style eq 'dot')
1925             {
1926             $dash = '.';
1927             }
1928             elsif ($line_style eq 'dash')
1929             {
1930             $dash = '-';
1931             }
1932             elsif ($line_style eq 'dotdash')
1933             {
1934             $dash = '.-';
1935             }
1936             else
1937             {
1938             warn "Invalid -lineStyle setting ($line_style) on line $tag, defaulting to normal\n";
1939             $ds -> set('-lineStyle' => 'normal');
1940             }
1941             $ds -> set('-dash' => $dash);
1942             }
1943             else
1944             {
1945             $dash = '';
1946             $ds -> set('-dash' => $dash);
1947             $ds -> set('-lineStyle' => 'normal');
1948             }
1949              
1950             my $point_style; #SS - added option to set point style
1951             if (!$ds -> get('-pointStyle'))
1952             {
1953             my $point_styles = $self -> cget('-pointShapes');
1954             $point_style = $point_styles -> [$index % @$point_styles];
1955             $ds -> set('-pointStyle' => $point_style);
1956             }
1957             else
1958             {
1959             $point_style = $ds -> get('-pointStyle');
1960             }
1961              
1962             my $point_size = $ds -> get('-pointSize'); #SS - added option to set point style
1963             if (!$point_size)
1964             {
1965             $point_size = 3;
1966             $ds -> set('-pointSize' => $point_size);
1967             }
1968              
1969             my $fill_point = $ds -> get('-fillPoint'); #SS - added option to set whether point should be filled
1970             if (! defined $fill_point)
1971             {
1972             $fill_point = 1;
1973             $ds -> set('-fillPoint' => $fill_point);
1974             }
1975              
1976             my $yax = $ds -> get('-yAxis'); # does this dataset use y or y1 axis
1977             # print "_draw_one_dataset: index <$index> color <$fill> y axis <$yax>\n";
1978             my $y_data = $ds -> get('-yData');
1979             my $x_data = $ds -> get('-xData');
1980             $x_data = [0..(scalar(@$y_data)-1)] unless (defined($x_data));
1981             my $y_error = $ds -> get('-yError');
1982              
1983             my $log_min = $self -> cget(-logMin);
1984             my $x = [];
1985             # if x-axis uses a log scale convert x data
1986             if ($self -> cget('-xType') eq 'log')
1987             {
1988             foreach my $e (@{$x_data})
1989             {
1990             $e = $log_min if ($e <= 0);
1991             push @{$x}, log10($e);
1992             } # end foreach
1993             }
1994             else # not log at all
1995             {
1996             $x = $x_data;
1997             }
1998             my $y = [];
1999             # just maybe we have a log plot to do. In that case must take the log of each point
2000             if
2001             (
2002             (($yax eq 'Y1') and ($self -> cget('-y1Type') eq 'log'))
2003             or (($yax eq 'Y') and ($self -> cget('-yType') eq 'log'))
2004             )
2005             {
2006             foreach my $e (@{$y_data})
2007             {
2008             $e = $log_min if ($e <= 0);
2009             push @{$y}, log10($e);
2010             } # end foreach
2011             }
2012             else # not log at all
2013             {
2014             $y = $y_data;
2015             }
2016              
2017             my $dy = [];
2018             if ($y_error)
2019             {
2020             my $a = 0;
2021              
2022             # in case we have a log plot to do we have to log the errors as well
2023             if
2024             (
2025             (($yax eq 'Y1') and ($self -> cget('-y1Type') eq 'log'))
2026             or (($yax eq 'Y') and ($self -> cget('-yType') eq 'log'))
2027             )
2028             {
2029             foreach my $e (@{$y_error})
2030             {
2031             # error values on log scale are larger below the point than above, i.e. we implement the concept of
2032             # plus and minus error already here by building absolute values (y+dy; y-dy) and going on with them;
2033             # just use positive errors
2034              
2035             $dy -> [0] -> [$a] = log10($y_data -> [$a] + abs($e)); # pluserror
2036              
2037             # if minuserror is below 0 trim to log_min
2038             my $tmp;
2039             if ($y_data -> [$a] - abs($e) <= 0)
2040             {
2041             $tmp = $log_min;
2042             }
2043             else
2044             {
2045             $tmp = $y_data -> [$a] - abs($e);
2046             }
2047              
2048             $dy -> [1] -> [$a] = log10($tmp); # minuserror
2049             $a++;
2050             }
2051             }
2052             else # not log at all
2053             {
2054             foreach my $e (@{$y_error})
2055             {
2056             $dy -> [0] -> [$a] = $y_data -> [$a] + abs($e);
2057             $dy -> [1] -> [$a] = $y_data -> [$a] - abs($e);
2058             $a++;
2059             }
2060             }
2061             }
2062              
2063             # need to make one array out of two
2064             my @xy_points;
2065              
2066             my @all_data;
2067             my $dyp = [];
2068             my $dym = [];
2069              
2070             # right here we need to go from data set coordinates to plot PIXEL coordinates
2071             my ($xReady, $yReady, $dyplusReady, $dyminusReady) = $self -> _ds_to_plot_pixels($x, $y, $dy, $yax);
2072             (@all_data) = $self -> _arrays_to_canvas_pixels('axis', $xReady, $yReady, $dyplusReady, $dyminusReady);
2073              
2074             # all data contains xy_points and plus and minus errors
2075             for (my $a = 0; $a < (@all_data/4); $a++)
2076             {
2077             $xy_points[$a * 2] = $all_data[$a * 4];
2078             $xy_points[$a * 2 + 1] = $all_data[$a * 4 + 1];
2079             $dyp -> [$a] = $all_data[$a * 4 + 2];
2080             $dym -> [$a] = $all_data[$a * 4 + 3];
2081             }
2082              
2083             # got to take care of the case where the data set is empty or just one point.
2084             return if (@xy_points == 0);
2085             if (@xy_points == 2)
2086             {
2087             # print "one point, draw a dot!\n";
2088             my ($xa, $ya) = ($xy_points[0], $xy_points[1]);
2089              
2090             $self -> _draw_point
2091             (
2092             $xa, $ya, $dyp -> [0], $dym -> [0], -pointStyle => $point_style, -pointSize => $point_size,
2093             -fillPoint => $fill_point, -fill => $fill, -tags => [$tag, $tag . 'point']
2094             );
2095             }
2096             else
2097             {
2098             $self -> _draw_one_dataset_b
2099             (
2100             -data => \@xy_points,
2101             -fill => $fill,
2102             -dash => $dash,
2103             -tags => [$tag],
2104             -xData => $x_data,
2105             -yData => $y_data,
2106             -yError => [$dyp, $dym],
2107             -noLine => $no_line,
2108             -pointStyle => $point_style,
2109             -pointSize => $point_size,
2110             -fillPoint => $fill_point
2111             );
2112             }
2113              
2114             # If multiple curves, turn the plot name in the legend and the line red when we enter the line with the cursor
2115             if (scalar(@{$self -> {-datasets}}) > 1)
2116             {
2117             $self -> bind
2118             (
2119             $tag, '' => sub
2120             {
2121             $self -> itemconfigure($tag, -fill => 'red');
2122             $self -> itemconfigure($tag . 'legend', -fill => 'red');
2123             $self -> itemconfigure($tag . 'point', -fill => 'red');
2124             }
2125             );
2126             $self -> bind
2127             (
2128             $tag, '' => sub
2129             {
2130             $self -> itemconfigure($tag, -fill => $fill);
2131             $self -> itemconfigure($tag . 'legend', -fill => $fill);
2132             if ($fill_point)
2133             {
2134             $self -> itemconfigure($tag . 'point', -fill => $fill);
2135             }
2136             else
2137             {
2138             $self -> itemconfigure($tag . 'point', -fill => '');
2139             }
2140             }
2141             );
2142             }
2143             return (1);
2144             }
2145              
2146             sub _center_text_v # given y1, y2, a font and a string
2147             {
2148             # return a y value for the start of the text
2149             # The system is in canvas, that is 0, 0 is top right.
2150             # return -1 if the text will just not fit
2151             my ($self, $y1, $y2, $f, $s) = @_;
2152             return (-1) if ($y1 > $y2);
2153             my $g = 'gowawyVVV';
2154             $self -> _create_text_v
2155             (
2156             0, 10_000, -text => $s, -anchor => 'sw',
2157             -font => $f, -tag => $g
2158             );
2159             my ($min_x, $min_y, $max_x, $max_y) = $self -> bbox($g);
2160             # print "_center_text_v: ($min_x, $min_y, $max_x, $max_y)\n";
2161             $self -> delete($g);
2162             my $space = $y2 - $y1;
2163             my $str_length = $max_y - $min_y;
2164             return (-1) if ($str_length > $space);
2165             # print "_center_text_v: $y1, $y2, space $space, strLen $str_length\n";
2166             return (($y1 + $y2 - $str_length) / 2);
2167             }
2168              
2169             sub _center_text # x1, x2 a font and a string
2170             {
2171             # return the x value fo where to start the text to center it
2172             # forget about leading and trailing blanks!!!!
2173             # Return -1 if the text will not fit
2174             my ($self, $x1, $x2, $f, $s) = @_;
2175             return (-1) if ($x1 > $x2);
2176             my $g = 'gowawy';
2177             $self -> createText
2178             (
2179             0, 10_000, -text => $s, -anchor => 'sw',
2180             -font => $f, -tags => [$g]
2181             );
2182             my ($min_x, $min_y, $max_x, $max_y) = $self -> bbox($g);
2183             $self -> delete($g);
2184             my $space = $x2-$x1;
2185             my $str_length = $max_x - $min_x;
2186             return (-1) if ($str_length > $space);
2187             return (($x1 + $x2 - $str_length) / 2);
2188             }
2189              
2190             sub _draw_one_dataset_b # takes same arguments as createLinePlot confused
2191             {
2192             # do clipping if needed
2193             # do plot with dots if needed
2194             my ($self, %args) = @_;
2195             my $xy_points = delete($args{'-data'});
2196             my $x_data = delete($args{'-xData'}); # Take the original data for use
2197             my $y_data = delete($args{'-yData'}); # in the balloon popups
2198             my $y_error = delete($args{'-yError'}); # and y errors if given
2199             my $no_line = delete($args{'-noLine'}); # Add a switch to allow points-only plots
2200             my $point_style = delete($args{'-pointStyle'}); # Add a switch to set point style
2201             my $point_size = delete($args{'-pointSize'}); # Add a switch to set point size
2202             my $fill_point = delete($args{'-fillPoint'}); # Add a switch to specify points as not filled
2203             # $self -> createLinePlot(-data => $xy_points, %args);
2204             $self -> _clip_plot(-data => $xy_points, %args) unless $no_line;
2205             my $h = $self -> height;
2206             my $w = $self -> width;
2207             my $borders = $self -> cget(-border);
2208             # Data points are only shown if the dataset has no line or the number of
2209             # points on the plot is less then or equal to the -maxPoints option
2210             my $points = @{$xy_points} / 2;
2211             my $inPoints = $self -> _count_in_points($xy_points);
2212             if (($inPoints <= $self -> cget(-maxPoints)) or $no_line)
2213             {
2214             my $tags = $args{'-tags'};
2215             my $mainTag = $$tags[0];
2216             for (my $i = 0; $i < $points; $i++)
2217             {
2218             my $specificPointTag = $mainTag . "($i)";
2219             my $generalPointTag = $mainTag . 'point';
2220             my @pointTags = (@$tags, $specificPointTag, $generalPointTag);
2221             my ($x, $y, $dyp, $dym) = (0, 0, 0, 0);
2222             ($x, $y, $dyp, $dym) =
2223             (
2224             $xy_points -> [$i * 2], $xy_points -> [$i * 2 + 1],
2225             $y_error -> [0] -> [$i], $y_error -> [1] -> [$i]
2226             );
2227              
2228             if ($self -> cget('-balloons'))
2229             {
2230             $self -> {BalloonPoints} -> {$specificPointTag}
2231             = sprintf('%.3g, %.3g', $$x_data[$i], $$y_data[$i]);
2232             }
2233             if
2234             (
2235             ($x >= $borders -> [3])
2236             and ($x <= ($w - $borders -> [1]))
2237             and ($y >= $borders -> [0])
2238             and ($y <= ($h - $borders -> [2]))
2239             )
2240             {
2241             $self -> _draw_point
2242             (
2243             $x, $y, $dyp, $dym, %args, -pointStyle => $point_style, -pointSize => $point_size,
2244             -fillPoint => $fill_point, -tags => \@pointTags
2245             )
2246             }
2247             }
2248             }
2249             return (1);
2250             }
2251              
2252             sub _draw_point
2253             {
2254             # Draws a point (includes drawing and clipping of error bars).
2255             my ($self, $x, $y, $dyp, $dym, %args) = @_;
2256              
2257             my $point_style = delete($args{-pointStyle});
2258             my $point_size = delete($args{-pointSize});
2259             my $fill_point = delete($args{-fillPoint});
2260             my $fill = $args{-fill};
2261              
2262             my $h = $self -> height;
2263             my $w = $self -> width;
2264             my $borders = $self -> cget(-border);
2265             my $pluserror = -1;
2266             my $minuserror = -1;
2267             if
2268             (
2269             ($x >= $borders -> [3])
2270             and ($x <= ($w - $borders -> [1]))
2271             and ($y >= $borders -> [0])
2272             and ($y <= ($h - $borders -> [2]))
2273             )
2274             {
2275             if (($dym) >= ($h - $borders->[2]))
2276             {
2277             # The error bar exceeds the lower border -> trim it;
2278             $minuserror = ($h - $borders->[2]);
2279             }
2280             if (($dyp) <= $borders -> [0])
2281             {
2282             # The error bar exceeds the upper border -> trim it;
2283             $pluserror = $borders->[0];
2284             }
2285             }
2286              
2287             # widths of error bar ends (coupled to point size)
2288             my $pluswidth = 0;
2289             my $minuswidth = 0;
2290              
2291             my $default_width = 3 + $point_size - 1.5;
2292             my $default_thickness = (1 + $point_size - 1.5) * 0.5;
2293              
2294             if ($minuserror == -1)
2295             {
2296             $minuserror = $dym; # keep default error bar
2297             $minuswidth = $default_width unless ($dym == $y); # if error=0 de facto no error bar
2298             }
2299              
2300             if ($pluserror == -1)
2301             {
2302             $pluserror = $dyp;
2303             $pluswidth = $default_width unless ($dyp == $y);
2304             }
2305              
2306             # draw error bars if not globally switched off
2307             if (($self -> cget('-showError')) && ($dyp != 0) && ($dym != 0))
2308             {
2309             $self -> createLine
2310             (
2311             $x, $minuserror, $x, $pluserror, -width => $default_thickness, %args
2312             );
2313             $self -> createLine
2314             (
2315             $x-$pluswidth, $pluserror, $x+$pluswidth, $pluserror, -width => $default_thickness, %args
2316             );
2317             $self -> createLine
2318             (
2319             $x-$minuswidth, $minuserror, $x+$minuswidth, $minuserror, -width => $default_thickness, %args
2320             );
2321             }
2322              
2323             unless ($point_style)
2324             {
2325             $point_style = '';
2326             }
2327              
2328             unless ($point_size)
2329             {
2330             warn "_draw_point: No point size specified for $args{-tags} -> [0]\n";
2331             $point_size = 3;
2332             }
2333              
2334             $args{-outline} = $args{-fill};
2335             unless ($fill_point)
2336             {
2337             $args{-fill} = '';
2338             }
2339              
2340             if ($point_style eq 'none')
2341             {
2342             }
2343             elsif ($point_style eq 'circle' or $point_style eq '')
2344             {
2345             $self -> createOval
2346             (
2347             $x - $point_size, $y - $point_size,
2348             $x + $point_size, $y + $point_size, %args
2349             );
2350             }
2351             elsif ($point_style eq 'square')
2352             {
2353             $self -> createRectangle
2354             (
2355             $x - $point_size, $y - $point_size,
2356             $x + $point_size, $y + $point_size, %args
2357             );
2358             }
2359             elsif ($point_style eq 'triangle')
2360             {
2361             $self -> createPolygon
2362             (
2363             $x - $point_size, $y - $point_size,
2364             $x + $point_size, $y - $point_size,
2365             $x, $y + $point_size, %args
2366             );
2367             }
2368             elsif ($point_style eq 'diamond')
2369             {
2370             $self -> createPolygon
2371             (
2372             $x - $point_size, $y,
2373             $x, $y + $point_size,
2374             $x + $point_size, $y,
2375             $x, $y - $point_size, %args
2376             );
2377             }
2378             else
2379             {
2380             warn "_draw_point: Point style $point_style is invalid, line = $args{-tags} -> [0]\n";
2381             $self -> createOval
2382             (
2383             $x - $point_size, $y - $point_size,
2384             $x + $point_size, $y + $point_size, %args
2385             );
2386             }
2387             return (1);
2388             }
2389              
2390             sub _count_in_points # array of x, y points
2391             {
2392             # count the points inside the plot box.
2393             my ($self, $xy_points) = @_;
2394             my $points = @{$xy_points} / 2;
2395             my $count = 0;
2396             my $h = $self -> height;
2397             my $w = $self -> width;
2398             my $borders = $self -> cget(-border);
2399              
2400             for (my $i = 0; $i < $points; $i++)
2401             {
2402             my ($x, $y) = ($xy_points -> [$i * 2], $xy_points -> [$i * 2 + 1]);
2403             if
2404             (
2405             ($x >= $borders -> [3])
2406             and ($x <= ($w - $borders -> [1]))
2407             and ($y >= $borders -> [0])
2408             and ($y <= ($h - $borders -> [2]))
2409             )
2410             {
2411             $count++;
2412             }
2413             }
2414             return ($count);
2415             }
2416              
2417             sub _clip_plot # -data => array ref which contains x, y points in Canvas pixels
2418             {
2419             # draw a multi point line but cliped at the borders
2420             my ($self, %args) = @_;
2421             my $xy_points = delete($args{'-data'});
2422             my $point_count = (@{$xy_points})/2;
2423             my $h = $self -> height;
2424             my $w = $self -> width;
2425             my $last_point = 1; # last pointed plotted is flaged as being out of the plot box
2426             my $borders = $self -> cget(-border);
2427             my @p; # a new array with points for line segment to be plotted
2428             my ($x, $y);
2429             my ($xp, $yp) = ($xy_points -> [0], $xy_points -> [1]); # get the first point
2430             if
2431             (
2432             ($xp >= $borders -> [3])
2433             and ($xp <= ($w - $borders -> [1]))
2434             and ($yp >= $borders -> [0])
2435             and ($yp <= ($h - $borders -> [2]))
2436             )
2437             {
2438             # first point is in, put points in the new array
2439             push @p, ($xp, $yp); # push the x, y pair
2440             $last_point = 0; # flag the last point as in
2441             }
2442             for (my $i = 1; $i < $point_count; $i++)
2443             {
2444             ($x, $y) = ($xy_points -> [$i * 2], $xy_points -> [$i * 2 + 1]);
2445             # print "_clip_plot: $i ($x $borders -> [3]) and ($x $w $borders -> [1]) ($y $borders -> [0]) ($y ($h - $borders -> [2])) lastPoint $last_point\n";
2446             if
2447             (
2448             ($x >= $borders -> [3])
2449             and ($x <= ($w - $borders -> [1]))
2450             and ($y >= $borders -> [0])
2451             and ($y <= ($h - $borders -> [2]))
2452             )
2453             {
2454             # OK, this point is in, if the last one was out then we have work to do
2455             if ($last_point == 1) # out
2456             {
2457             $last_point = 0; # in
2458             my ($xn, $yn) = $self -> _clip_line_in_out
2459             (
2460             $x, $y, $xp, $yp,
2461             $borders -> [3], $borders -> [0],
2462             $w - $borders -> [1], $h - $borders -> [2]
2463             );
2464             push (@p, ($xn, $yn));
2465             push (@p, ($x, $y));
2466             ($xp, $yp) = ($x, $y);
2467             }
2468             else # last point was in, this in so we just add a point to the line and carry on
2469             {
2470             push (@p, ($x, $y));
2471             ($xp, $yp) = ($x, $y);
2472             } # end else
2473             }
2474             else # this point out
2475             {
2476             my @args = %args;
2477             if ($last_point == 0) # in
2478             {
2479             # this point is out, last one was in, need to draw a line
2480             my ($x_edge, $y_edge) = $self -> _clip_line_in_out
2481             (
2482             $xp, $yp, $x, $y,
2483             $borders -> [3], $borders -> [0],
2484             $w - $borders -> [1], $h - $borders -> [2]
2485             );
2486             push @p, $x_edge, $y_edge;
2487             $self -> createLine(\@p, %args);
2488             splice(@p, 0); # empty the array?
2489             $last_point = 1; # out
2490             ($xp, $yp) = ($x, $y );
2491             }
2492             else # two points in a row out but maybe the lies goes thru the active area
2493             {
2494             # print "clip two points in a row out of box.\n";
2495             my $p = $self -> _clip_line_out_out
2496             (
2497             $xp, $yp, $x, $y,
2498             $borders -> [3], $borders -> [0],
2499             $w - $borders -> [1], $h - $borders -> [2]
2500             );
2501             $self -> createLine($p, %args)if (@$p >= 4);
2502             $last_point = 1; # out!
2503             ($xp, $yp) = ($x, $y );
2504             } # end else
2505             }
2506             } # end loop
2507             # now when we get out of the loop if there are any points in the @p array, make a line
2508             $self -> createLine(\@p, %args) if (@p >= 4);
2509             return (1);
2510             }
2511              
2512             sub _clip_line_out_out ## no critic (Subroutines::ProhibitManyArgs)
2513             { # x, y , x, y and x, y corners of the box
2514              
2515             # see if the line goes thru the box
2516             # If so, draw the line
2517             # else do nothing
2518             my ($self, $x1, $y1, $x2, $y2, $xb1, $yb1, $xb2, $yb2) = @_;
2519             my (@p, $x, $y);
2520             # print "_clip_line_out_out: ($x1, $y1) , ($x2, $y2), ($xb1, $yb1) , ($xb2, $yb2)\n";
2521             return (\@p) if (($x1 < $xb1) and ($x2 < $xb1)); # line not in the box
2522             return (\@p) if (($x1 > $xb2) and ($x2 > $xb2));
2523             return (\@p) if (($y1 > $yb2) and ($y2 > $yb2));
2524             return (\@p) if (($y1 < $yb1) and ($y2 < $yb1));
2525             # get here the line might pass thru the plot box
2526             # print "_clip_line_out_out: p1($x1, $y1), p2($x2, $y2), box1($xb1, $yb1), box2($xb2, $yb2)\n";
2527             if ($x1 != $x2)
2528             {
2529             my $m = ($y1 - $y2) / ($x1 - $x2); # as in y = mx + c
2530             my $c = $y1 - $m * $x1;
2531             # print "_clip_line_out_out: line m $m c $c\n";
2532             $x = ($m != 0) ? ($yb1 - $c) / $m : $x1; # print "$x $yb1\n";
2533             push @p, ($x, $yb1) if (($x >= $xb1) and ($x <= $xb2));
2534             $x = ($m != 0) ? ($yb2 - $c) / $m : $x1;
2535             push @p, ($x, $yb2) if (($x >= $xb1) and ($x <= $xb2));
2536             $y = $m * $xb1 + $c;
2537             push @p, ($xb1, $y) if (($y >= $yb1) and ($y <= $yb2));
2538             $y = $m * $xb2 + $c;
2539             push @p, ($xb2, $y) if (($y >= $yb1) and ($y <= $yb2));
2540             }
2541             else # Handle vertical lines...
2542             {
2543             $x = $x1; # This is also $x2 of course!
2544             push @p, ($x, $yb1) if (($x >= $xb1) and ($x <= $xb2));
2545             $x = $x1;
2546             push @p, ($x, $yb2) if (($x >= $xb1) and ($x <= $xb2));
2547             }
2548             # print "_clip_line_out_out: @p", "\n";
2549             return (\@p)
2550             }
2551              
2552             sub _clip_line_in_out ## no critic (Subroutines::ProhibitManyArgs)
2553             { # x, y (1 in), x, y (2 out) and x, y corners of the box
2554              
2555             # We have two points, one in the box, one outside of the box
2556             # Find where the line between the two points intersects the edges of the box
2557             # returns that point
2558             # Notebook page 106
2559             my ($self, $x1, $y1, $x2, $y2, $xb1, $yb1, $xb2, $yb2) = @_; ## no critic (Subroutines::ProhibitManyArgs)
2560             # print "_clip_line_in_out: ($x1, $y1) , ($x2, $y2), ($xb1, $yb1) , ($xb2, $yb2)\n";
2561             my ($xi, $yi);
2562             if ($x1 == $x2) # line par to y axis
2563             {
2564             # print "_clip_line_in_out: Line parallel to y axis\n";
2565             $xi = $x1;
2566             $yi = ($y2 < $yb1) ? $yb1 : $yb2;
2567             return ($xi, $yi);
2568             }
2569             if ($y1 == $y2) # line par to x axis
2570             {
2571             # print "_clip_line_in_out: Line parallel to y axis\n";
2572             $yi = $y1;
2573             $xi = ($x2 < $xb1) ? $xb1 : $xb2;
2574             return ($xi, $yi);
2575             }
2576             # y = mx + b; m = dy / dx b = y1 - m * x1 x = (y - b) / m
2577             if (($x1 - $x2) != 0)
2578             {
2579             my $m = ($y1 - $y2) / ($x1 - $x2);
2580             my $c = $y1 - $m * $x1;
2581             if ($y2 <= $y1) # north border
2582             {
2583             $xi = ($yb1 - $c) / $m;
2584             return ($xi, $yb1) if (($xi >= $xb1) and ($xi <= $xb2));
2585             }
2586             else # south border
2587             {
2588             $xi = ($yb2-$c) / $m;
2589             return ($xi, $yb2) if (($xi >= $xb1) and ($xi <= $xb2));
2590             }
2591             if ($x2 <= $x1) # west border
2592             {
2593             $yi = $m * $xb1 + $c;
2594             return ($xb1, $yi) if (($yi >= $yb1) and ($yi <= $yb2));
2595             }
2596             # only one remaining is east border
2597             $yi = $m * $xb2 + $c;
2598             return ($xb2, $yi) if (($yi >= $yb1) and ($yi <= $yb2));
2599             }
2600             else # dx == 0, vertical line, north or south border
2601             {
2602             return ($x1, $yb1) if ($y2 <= $yb1);
2603             return ($x1, $yb2) if ($y2 >= $yb2);
2604             }
2605             warn '_clip_line_in_out() reach this point in the code';
2606             return (0, 0);
2607             }
2608              
2609             # There are three coordinate systems in use.
2610             # 1. World - Units are the physical system being plotted. Amps, DJ Average, dollars, etc
2611             # 2. Plot - Units are pixels. The (0, 0) point is the lower left corner of the canvas
2612             # 3. Canvas - Units are pixels. The (0, 0) point is the upper left corner of the canvas.
2613              
2614             sub _to_world_points # x, y in the Canvas system
2615             {
2616             # convert to World points
2617             # get points on canvas from system in pixels, need to change them into units in the plot
2618             my ($self, $xp, $yp) = @_;
2619             my $borders = $self -> cget(-border); # north, east, south, west
2620             my $s = $self -> cget(-scale); # min X, max X, interval, min y, max y,
2621             my $h = $self -> height;
2622             my $w = $self -> width;
2623             my $x = ($xp - $borders -> [3]) * ($s -> [1] - $s -> [0])
2624             / ($w - $borders -> [1] - $borders -> [3]) + $s -> [0];
2625             my $y = (($h-$yp) - $borders -> [2]) * ($s -> [4] - $s -> [3])
2626             / ($h - $borders -> [0] - $borders -> [2]) + $s -> [3];
2627             # but if the axes are log some more work to do.
2628             my $y1 = (($h - $yp) - $borders -> [2]) * ($s -> [7] - $s -> [6])
2629             / ($h - $borders -> [0] - $borders -> [2]) + $s -> [6];
2630             $x = 10 ** $x if ($self -> cget('-xType') eq 'log');
2631             $y = 10 ** $y if ($self -> cget('-yType') eq 'log');
2632             $y1 = 10 ** $y1 if ($self -> cget('-y1Type') eq 'log');
2633             # print "_to_world_points: ($xp, $yp) to ($x, $y, $y1)\n";
2634             return ($x, $y, $y1);
2635             }
2636              
2637             sub _to_canvas_pixels # which, x, y
2638             {
2639             # given an x, y value in axis or canvas system return x, y in Canvas pixels.
2640             # axis => x, y are pixels relative to where the border is
2641             # canvas => x, y are pixels in the canvas system.
2642             # more to follow ?
2643             my ($self, $which, $x, $y) = @_;
2644             my ($x_out, $y_out);
2645             if ($which eq 'axis')
2646             {
2647             my $borders = $self -> cget(-border);
2648             return ($x + $borders -> [3], $self -> height - ($y + $borders -> [2]));
2649             }
2650             if ($which eq 'canvas')
2651             {
2652             return ($x, $self -> height - $y);
2653             }
2654             } # end _to_canvas_pixels
2655              
2656             sub _arrays_to_canvas_pixels # which, x array ref, y array ref also errors
2657             {
2658             # given x array ref and y aray ref generate the one array, xy in canvas pixels
2659             my ($self, $which, $xa, $ya, $dyap, $dyam) = @_;
2660             my (@xy_out, my @dyp_out, my @dym_out);
2661             my $h = $self -> height;
2662             my $borders = $self -> cget(-border);
2663             if ($which eq 'axis')
2664             {
2665             for (my $i = 0; $i < @$ya; $i++)
2666             {
2667             $xy_out[$i * 4] = $xa -> [$i] + $borders -> [3];
2668             $xy_out[$i * 4 + 1] = $h - ($ya -> [$i] + $borders -> [2]);
2669             $xy_out[$i * 4 + 2] = $h - ($dyap -> [$i] + $borders -> [2]);
2670             $xy_out[$i * 4 + 3] = $h - ($dyam -> [$i] + $borders -> [2]);
2671             }
2672             return (@xy_out);
2673             }
2674             }
2675              
2676             sub _ds_to_plot_pixels # ref to xArray and yArray with ds values, which y axis
2677             {
2678             # ds is dataSet. They are in world system
2679             # convert to Plot pixels, return ref to converted x array and y array
2680             # if y-errors are given, also convert these and return two more arrays
2681             # - ypluserror, yminuserror
2682             # if no y-errors are given, set them virtually to zero and return the arrays as well
2683              
2684             my ($self, $xa, $ya, $dya, $y_axis) = @_;
2685             my $s = $self -> cget(-scale);
2686             my ($x_min, $x_max, $y_min, $y_max);
2687             ($x_min, $x_max, $y_min, $y_max) = ($s -> [0], $s -> [1], $s -> [3], $s -> [4]);
2688             ($x_min, $x_max, $y_min, $y_max) = ($s -> [0], $s -> [1], $s -> [6], $s -> [7]) if ($y_axis eq 'Y1');
2689             # print "_ds_to_plot_pixels: X($x_min, $x_max), Y($y_min, $y_max)\n";
2690             my $borders = $self -> cget(-border);
2691             my ($nb, $eb, $sb, $wb) = ($borders -> [0], $borders -> [1], $borders -> [2], $borders -> [3]);
2692             my $h = $self -> height;
2693             my $w = $self -> width;
2694             my (@xR, @yR, @dypR, @dymR); # converted values to be returned (including errors)
2695             my $sfX = ($w-$eb-$wb) / ($x_max - $x_min);
2696             my $sfY = ($h-$nb-$sb) / ($y_max - $y_min);
2697             my ($x, $y);
2698             for (my $i = 0; $i < @{$xa}; $i++)
2699             {
2700             push @xR, ($xa -> [$i] - $x_min) * $sfX if (defined($xa -> [$i]));
2701             push @yR, ($ya -> [$i] - $y_min) * $sfY if (defined($ya -> [$i]));
2702              
2703             # if y-Errors are given, also convert to pixels
2704             if ($dya -> [0])
2705             {
2706             push @dypR, ($dya -> [0] -> [$i] - $y_min) * $sfY; # errors are absolute vals from here...
2707             push @dymR, ($dya -> [1] -> [$i] - $y_min) * $sfY;
2708             }
2709             else
2710             {
2711             push @dypR, ($ya -> [$i] - $y_min) * $sfY; # if no errors are given, set them to zero
2712             push @dymR, ($ya -> [$i] - $y_min) * $sfY;
2713             }
2714             }
2715             return (\@xR, \@yR, \@dypR, \@dymR);
2716             }
2717              
2718             sub _nice_range # input is min, max,
2719             {
2720             # return is a new min, max and an interval for the tick marks
2721             # interval is not the number of intervals but the size of the interval
2722             # find a good min, max and interval for the axis
2723             # if min > max return min 0, max 100, interval of 10.
2724             my ($min, $max) = @_;
2725             my $delta = $max - $min;
2726             return (0, 100, 10) if ($delta < 0); # AC: Set standard scale for negative ranges
2727             return (int($min + 0.5) - 1, int($min + 0.5) + 1, 1) if ($delta <= 1e-15); # AC: Set special scale for zero, or v. small ranges (v. small is usually caused by rounding errors!)
2728             my $r = ($max != 0) ? $delta/$max : $delta;
2729             $r = -$delta / $min if ($max < 0);
2730             my $spaces = 10; # number
2731             # don't want a lot of ticks if the size of the space is very small compaired to values
2732             $spaces = 2 if ($r < 1e-2);
2733              
2734             while (1) # do this until a return
2735             {
2736             # print "ratio <$r> \n";
2737             # $spaces = 2 if ($r < 1e-08);
2738             my $interval = $delta / $spaces;
2739             my $power = floor(log10($delta));
2740             # print "min, max $min, $max delta $delta power $power interval $interval $spaces\n";
2741             # find a good interval for the ticks
2742             $interval = $interval * (10 ** -$power) * 10;
2743             # print "min, max $min, $max delta $delta power $power interval $interval\n";
2744             # now round this up the next whole number but not 3 or 6, 7 or 9.
2745             # leaves 1, 2, 4, 5, 8
2746             $interval = ceil($interval);
2747             $interval = 8 if (($interval == 7) or ($interval == 6));
2748             $interval = 10 if ($interval == 9);
2749             $interval = 4 if ($interval == 3);
2750             #print "min, max $min, $max delta $delta power $power interval $interval\n";
2751             $interval = $interval * (10 ** (+$power - 1));
2752             #print "min, max $min, $max delta $delta power $power interval $interval\n";
2753             # find the new min
2754             my ($new_max, $new_min);
2755             my $new_delta = $interval * $spaces;
2756             if ($new_delta == $delta)
2757             {
2758             $new_max = $max;
2759             $new_min = $min;
2760             }
2761             else
2762             {
2763             my $n = $min / $interval;
2764             my $n_floor = floor($n);
2765             # print "n $n floor of n is $n_floor \n";
2766             $new_min = $n_floor * $interval;
2767             $new_max = $new_min + $new_delta;
2768             if ($new_max <= $max)
2769             {
2770             # Add an extra space to include data missed off by reducing the minimum value
2771             $new_delta += $interval;
2772             $spaces++;
2773             $new_max = $new_min + $new_delta;
2774             }
2775             }
2776             # print "_nice_range: min, max $min, $max delta $delta power $power interval $interval newMin $new_min newMax $new_max \n";
2777              
2778             # now see how much of the space has been used. If there is a lot empty, increase the number of spaces (ticks)
2779             return ($new_min, $new_max, $interval) if ($spaces <= 3);
2780             return ($new_min, $new_max, $interval) if ((($new_delta / $delta) < 1.4) and ($new_max >= $max));
2781             $spaces++;
2782             }
2783              
2784             die '_nice_range() should not reach this point in the code';
2785             }
2786              
2787             sub _log_range # min, max
2788             {
2789             # for scaling a log axis
2790             #returns a max and min, intervals and an array ref that contains labels for the ticks
2791             # Optional args -tickFormat
2792             # The sprintf format to use. If not specified, then '1e%3.2d' will be used
2793             # for values less than zero and '1e+%2.2d' will be used for values of zero
2794             # or more.
2795             my ($self, $min, $max, %args) = @_;
2796             my $tick_format = delete $args{-tickFormat};
2797              
2798             unless (defined($min) and defined($max))
2799             {
2800             $min = 0.1;
2801             $max = 1000;
2802             }
2803              
2804             if ($min <= 0)
2805             {
2806             my $t = $self -> cget(-logMin);
2807             # print "Can't log plot data that contains numbers less than or equal to zero.\n";
2808             # print "Data min is: <$min>. Changed to $t\n";
2809             $min = $self -> cget(-logMin);
2810             # set a flag to indicate the log data must be checked for min!
2811             $self -> {-logCheck} = 1; # true
2812             }
2813             my $delta = $max - $min;
2814             my $first;
2815             my @t_label;
2816              
2817             my $max_p = ceil(log10($max));
2818             $max_p = $max_p + 1 if ($max_p < 0);
2819             my $min_p = floor(log10($min));
2820             my $f;
2821             # print "_log_range: max $max, min $min, $max_p, $min_p)\n";
2822             foreach my $t ($min_p..$max_p)
2823             {
2824             my $n = 10.0 ** $t;
2825             # print "_log_range: <$n> <$t>\n";
2826             if ($tick_format)
2827             {
2828             $f = sprintf($tick_format, $t);
2829             }
2830             elsif ($t < 0)
2831             {
2832             $f = sprintf('1e%3.2d', $t);
2833             }
2834             else
2835             {
2836             $f = sprintf('1e+%2.2d', $t);
2837             }
2838             # print "_log_range: $f \n";
2839             push @t_label, $f;
2840             }
2841             return ($min_p, $max_p, 1, \@t_label);
2842             # look returning min Power and the max Power. Note the power step is always 1 this might not be good
2843             # used 1e-10, 1e-11 and so on. Looks good to me!
2844             }
2845              
2846             1;
2847