File Coverage

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


line stmt bran cond sub pod time code
1             package Tk::PlotDataset;
2              
3             =head1 NAME
4              
5             Tk::PlotDataset - An extended version of the canvas widget for plotting 2D line
6             graphs. Plots have a legend, zooming capabilities and the option to display
7             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 2016 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             # Version 16 by sd on 15/08/2016
639             # Fixed double usage of my in declaration of variable.
640              
641 1     1   13215 use strict;
  1         2  
  1         22  
642 1     1   2 use warnings;
  1         1  
  1         18  
643              
644 1     1   14 use 5.005_03;
  1         3  
645              
646 1     1   2 use Carp;
  1         1  
  1         47  
647 1     1   450 use POSIX;
  1         4358  
  1         3  
648 1     1   2155 use base qw/Tk::Derived Tk::Canvas/;
  1         1  
  1         471  
649             use Tk::Balloon;
650             use vars qw($VERSION);
651              
652             $VERSION = '2.05';
653              
654             Construct Tk::Widget 'PlotDataset';
655              
656             sub ClassInit ## no critic (NamingConventions::ProhibitMixedCaseSubs)
657             {
658             my ($class, $mw ) = @_;
659             $class -> SUPER::ClassInit($mw);
660              
661             return (1);
662             }
663              
664             # Class data to track mega-item items. Not used as yet.
665             my $id = 0;
666             my %ids = ();
667              
668             sub Populate ## no critic (NamingConventions::ProhibitMixedCaseSubs)
669             {
670             my ($self, $args) = @_;
671              
672             my @def_colors =
673             qw/
674             gray SlateBlue1 blue1 DodgerBlue4 DeepSkyBlue2 SeaGreen3
675             green4 khaki4 gold3 gold1 firebrick1 brown4 magenta1 purple1 HotPink1
676             chocolate1 black
677             /;
678             my @def_point_shapes = qw/circle square triangle diamond/;
679             $self -> ConfigSpecs
680             (
681             -colors => ['PASSIVE', 'colors', 'Colors', \@def_colors],
682             -pointShapes => ['PASSIVE', 'pointShapes', 'PointShapes', \@def_point_shapes],
683             -border => ['PASSIVE', 'border', 'Border', [25, 50, 100, 50]],
684             -scale => ['PASSIVE', 'scale', 'Scale', [0, 100, 10, 0, 100, 10, 0, 100, 10]],
685             -zoom => ['PASSIVE', 'zoom', 'Zoom', [0, 0, 0, 0, 0]],
686             -plotTitle => ['PASSIVE', 'plottitle', 'PlotTitle', ['Default Plot Title', 25 ]],
687             -xlabel => ['PASSIVE', 'xlabel', 'Xlabel', 'X Axis Default Label'],
688             -ylabel => ['PASSIVE', 'ylabel', 'Ylabel', 'Y Axis Default Label'],
689             -y1label => ['PASSIVE', 'Y1label', 'Y1label', 'Y1 Axis Default Label'],
690             -xlabelPos => ['PASSIVE', 'xlabelPos', 'XlabelPos', 40],
691             -ylabelPos => ['PASSIVE', 'ylabelPos', 'YlabelPos', 40],
692             -y1labelPos => ['PASSIVE', 'Y1labelPos', 'Y1labelPos', 40],
693             -xTickLabel => ['PASSIVE', 'xticklabel', 'Xticklabel', undef],
694             -yTickLabel => ['PASSIVE', 'yticklabel', 'Yticklabel', undef],
695             -y1TickLabel => ['PASSIVE', 'y1ticklabel', 'Y1ticklabel', undef],
696             -xTickFormat => ['PASSIVE', 'xtickformat', 'Xtickformat', undef],
697             -yTickFormat => ['PASSIVE', 'ytickformat', 'Ytickformat', undef],
698             -y1TickFormat => ['PASSIVE', 'y1tickformat', 'Y1tickformat', undef],
699             -balloons => ['PASSIVE', 'balloons', 'Balloons', 1],
700             -legendPos => ['PASSIVE', 'legendPos', 'LegendPos', ['bottom', 80]],
701             -xType => ['PASSIVE', 'xtype', 'Xtype', 'linear'], # could be log
702             -yType => ['PASSIVE', 'ytype', 'Ytype', 'linear'], # could be log
703             -y1Type => ['PASSIVE', 'y1type', 'Y1type', 'linear'], # could be log
704             -fonts => ['PASSIVE', 'fonts', 'Fonts', ['Arial 8', 'Arial 8', 'Arial 10 bold', 'Arial 10']],
705             -autoScaleY => ['PASSIVE', 'autoscaley', 'AutoScaleY', 'On'],
706             -autoScaleX => ['PASSIVE', 'autoscalex', 'AutoScaleX', 'On'],
707             -autoScaleY1 => ['PASSIVE', 'autoscaley1', 'AutoScaleY1', 'On'],
708             -showError => ['PASSIVE', 'showError', 'ShowError', 1],
709             -maxPoints => ['PASSIVE', 'maxPoints', 'MaxPoints', 20],
710             -logMin => ['PASSIVE', 'logMin', 'LogMin', 0.001],
711             -redraw => ['PASSIVE', 'redraw', 'Redraw', undef],
712             -zoomButton => ['PASSIVE', 'zoomButton', 'ZoomButton', 1]
713             );
714              
715             $self -> SUPER::Populate($args);
716              
717             #helvetica Bookman Schumacher
718             # The four fonts are axis ticks[0], axis lables[1], plot title[2], and legend[3]
719             $self -> {-logCheck} = 0; # false, don't need to check on range of log data
720             # OK, setup the dataSets list
721             $self -> {-datasets} = []; # empty array, will be added to
722             $self -> {-zoomStack} = []; # empty array which will get the zoom stack
723              
724             # Some bindings here
725             # Add ballon help for the data points...
726             my $parent = $self -> parent; # ANDY
727             $self -> {Balloon} = $parent -> Balloon;
728             $self -> {BalloonPoints} = {};
729             $self -> {Balloon}
730             -> attach($self, -balloonposition => 'mouse', -msg => $self -> {BalloonPoints});
731              
732             # Must use Tk:: here to avoid calling the canvas::bind method
733             $self -> Tk::bind('' => [\&_resize]);
734              
735             return (1);
736             } # end Populate
737              
738             # When using the inherited configure method, array items cause
739             # memory leaks, so these will be handled by this method instead.
740             sub configure ## no critic (RequireFinalReturn) - Does not recognise return statement at end of method
741             {
742             my ($self, %args) = @_;
743              
744             foreach my $array_item (qw/-scale -xTickLabel -yTickLabel -y1TickLabel
745             -border -zoom -plotTitle -fonts -colors -legendPos/)
746             {
747             if (my $value = delete $args{$array_item})
748             {
749             $self -> {'Configure'}{$array_item} = $value;
750             }
751             }
752              
753             if (my $value = delete $args{-zoomButton})
754             {
755             $self -> _set_zoom_button($value);
756             }
757              
758             if (my @args = %args)
759             {
760             return ($self -> SUPER::configure(@args));
761             }
762              
763             return (1);
764             }
765              
766             sub _resize # called when the window changes size (configured)
767             {
768             my ($self) = @_; # This is the canvas (Plot)
769              
770             my $w = $self -> width; # Get the current size
771             my $h = $self -> height;
772             # print "_resize: mw size is ($h, $w)\n";
773             $self -> _rescale;
774              
775             return (1);
776             }
777              
778             sub _rescale # all, active, not
779             {
780             # _rescale the plot and redraw. Scale to all or just active as per argument
781             my ($self, $how, %args) = @_;
782             $self -> delete('all'); # empty the canvas, erase
783             $self -> _scale_plot($how) if (defined($how) and $how ne 'not'); # Get max and min for scalling
784             $self -> _draw_axis; # both x and y for now
785             $self -> _titles;
786             $self -> _draw_datasets(%args);
787             $self -> _legends(%args);
788             $self -> _call_redraw_callback;
789              
790             return (1);
791             }
792              
793             sub _call_redraw_callback
794             {
795             my ($self) = @_;
796             if (my $callback = $self -> cget(-redraw))
797             {
798             $callback = [$callback] if (ref($callback) eq 'CODE');
799             die "You must pass a list reference when using -redraw.\n"
800             unless ref($callback) eq 'ARRAY';
801             my ($sub, @args) = @$callback;
802             die "The array passed with the -redraw option must have a code reference as it's first element.\n"
803             unless ref($sub) eq 'CODE';
804             &$sub($self, @args);
805             }
806             return (1);
807             }
808              
809             sub _set_zoom_button
810             {
811             my ($self, $new_button) = @_;
812              
813             my $current_button = $self -> cget(-zoomButton);
814              
815             # Remove current bindings if any exist
816             if (defined($current_button) and $current_button =~ m/^[1-5]$/)
817             {
818             $self -> Tk::bind('', undef);
819             $self -> Tk::bind('', undef);
820             $self -> Tk::bind('', undef);
821             }
822              
823             # Apply new bindings if value is a valid mouse button
824             if ($new_button =~ m/^[1-5]$/)
825             {
826             $self -> Tk::bind('', [\&_zoom, 0]);
827             $self -> Tk::bind('', [\&_zoom, 1]);
828             $self -> Tk::bind('', [\&_zoom, 2]);
829             }
830              
831             # Set -zoomButton option in object
832             $self -> {'Configure'}{-zoomButton} = $new_button;
833              
834             return (1);
835             }
836              
837             sub _zoom
838             {
839             # start to do the zoom
840             my ($self, $which) = @_;
841             my $z;
842             # print "_zoom: which is <$which> self <$self> \n"if ($which == 1 or $which == 3);
843             if ($which == 0) # button 1 down
844             {
845             my $e = $self -> XEvent;
846             $z = $self -> cget('-zoom');
847             $z -> [0] = $e -> x; $z -> [1] = $e -> y;
848             $self -> configure('-zoom' => $z);
849             }
850             elsif ($which == 1) # button 1 release, that is do zoom
851             {
852             my $e = $self -> XEvent;
853             $z = $self -> cget('-zoom');
854             $z -> [2] = $e -> x; $z -> [3] = $e -> y;
855             $self -> configure('-zoom' => $z);
856             # OK, we can now do the zoom
857             # print "_zoom: $z -> [0], $z -> [1] $z -> [2], $z -> [3] \n";
858              
859             # If the box is small we undo one level of zoom
860             if ((abs($z -> [0]-$z -> [2]) < 3) and (abs($z -> [1]-$z -> [3]) < 3))
861             {
862             # try to undo one level of zoom
863             if (@{$self -> {'-zoomStack'}} == 0) # no zooms to undo
864             {
865             $z = $self -> cget('-zoom');
866             $self -> delete($z -> [4])if ($z -> [4] != 0);
867             return;
868             }
869              
870             my $s = pop(@{$self -> {'-zoomStack'}});
871             # print "_zoom: off stack $s -> [3], $s -> [4] \n";
872             $self -> configure(-scale => $s);
873             if ($self -> cget('-xType') eq 'log')
874             {
875             my ($aa, $bb) = (10**$s -> [0], 10**$s -> [1]);
876             # print "_zoom: a $aa b $bb \n";
877             my ($x_min_p, $x_max_p, $x_intervals, $tick_labels) = $self -> _log_range
878             (
879             $aa, $bb,
880             -tickFormat => $self -> cget('-xTickFormat')
881             );
882             # print "_zoom: $tick_labels \n";
883             $self -> configure(-xTickLabel => $tick_labels);
884             }
885             if ($self -> cget('-yType') eq 'log')
886             {
887             my ($aa, $bb) = (10**$s -> [3], 10**$s -> [4]);
888             # print "_zoom: a $aa b $bb \n";
889             my ($y_min_p, $y_max_p, $y_intervals, $tick_labels) = $self -> _log_range
890             (
891             $aa, $bb,
892             -tickFormat => $self -> cget('-yTickFormat')
893             );
894             # print "_zoom: $tick_labels \n";
895             $self -> configure(-yTickLabel => $tick_labels);
896             }
897             if ($self -> cget('-y1Type') eq 'log')
898             {
899             my ($aa, $bb) = (10**$s -> [6], 10**$s -> [7]);
900             # print "_zoom: for y1 log $aa b $bb \n";
901             my ($y_min_p, $y_max_p, $y_intervals, $tick_labels) = $self -> _log_range
902             (
903             $aa, $bb,
904             -tickFormat => $self -> cget('-y1TickFormat')
905             );
906             # print "_zoom: y1 $tick_labels \n";
907             $self -> configure(-y1TickLabel => $tick_labels);
908             }
909             }
910             else # box not small, time to zoom
911             {
912             my ($x1w, $y1w, $y11w) = $self -> _to_world_points($z -> [0], $z -> [1]);
913             my ($x2w, $y2w, $y12w) = $self -> _to_world_points($z -> [2], $z -> [3]);
914             my $z; #holdem
915             if ($x1w > $x2w)
916             {
917             $z = $x1w;
918             $x1w = $x2w;
919             $x2w = $z;
920             }
921             if ($y1w > $y2w)
922             {
923             $z = $y1w;
924             $y1w = $y2w;
925             $y2w = $z;
926             }
927             if ($y11w > $y12w)
928             {
929             $z = $y11w;
930             $y11w = $y12w;
931             $y12w = $z;
932             }
933              
934             # We've had trouble with extreme zooms, so trap that here...
935             if (($x2w - $x1w < 1e-12) or ($y2w - $y1w < 1e-12) or ($y12w - $y11w < 1e-12))
936             {
937             $z = $self -> cget('-zoom');
938             $self -> delete($z -> [4]) if ($z -> [4] != 0);
939             return;
940             }
941              
942             # push the old scale values on the zoom stack
943             push(@{$self -> {'-zoomStack'}}, $self -> cget(-scale));
944             # now _rescale
945             # print "_zoom: Rescale ($y1w, $y2w) ($x1w, $x2w) \n";
946             my ($y_min_p, $y_max_p, $y_intervals) = _nice_range($y1w, $y2w);
947             my ($y1min_p, $y1max_p, $y1intervals) = _nice_range($y11w, $y12w);
948             my ($x_min_p, $x_max_p, $x_intervals) = _nice_range($x1w, $x2w);
949             my ($x_tick_labels, $y_tick_labels, $y1_tick_labels);
950             if ($self -> cget('-xType') eq 'log')
951             {
952             ($x_min_p, $x_max_p, $x_intervals, $x_tick_labels) = $self -> _log_range
953             (
954             $x1w, $x2w,
955             -tickFormat => $self -> cget('-xTickFormat')
956             );
957             }
958             if ($self -> cget('-yType') eq 'log')
959             {
960             ($y_min_p, $y_max_p, $y_intervals, $y_tick_labels) = $self -> _log_range
961             (
962             $y1w, $y2w,
963             -tickFormat => $self -> cget('-yTickFormat')
964             );
965             }
966             if ($self -> cget('-y1Type') eq 'log')
967             {
968             ($y1min_p, $y1max_p, $y1intervals, $y1_tick_labels) = $self -> _log_range
969             (
970             $y11w, $y12w,
971             -tickFormat => $self -> cget('-y1TickFormat')
972             );
973             }
974              
975             # Swap minimum and maximum values if their axis has been reversed
976             my $curr_scale = $self -> cget(-scale);
977             ($x_min_p, $x_max_p) = ($x_max_p, $x_min_p) if ($$curr_scale[0] > $$curr_scale[1]);
978             ($y_min_p, $y_max_p) = ($y_max_p, $y_min_p) if ($$curr_scale[3] > $$curr_scale[4]);
979             ($y1min_p, $y1max_p) = ($y1max_p, $y1min_p) if ($$curr_scale[6] > $$curr_scale[7]);
980              
981             # print "_zoom: ($x_min_p, $x_max_p, $x_intervals) xTickLabels <$x_tick_labels> \n";
982             $self -> configure(-xTickLabel => $x_tick_labels);
983             $self -> configure(-yTickLabel => $y_tick_labels);
984             # print "($x_min_p, $x_max_p, $x_intervals), ($y_min_p, $y_max_p, $y_intervals), ($y1min_p, $y1max_p, $y1intervals)\n";
985             $self -> configure
986             (
987             -scale =>
988             [
989             $x_min_p, $x_max_p, $x_intervals,
990             $y_min_p, $y_max_p, $y_intervals,
991             $y1min_p, $y1max_p, $y1intervals
992             ]
993             );
994             }
995              
996             $self -> delete('all');
997             # draw again
998             $self -> _draw_axis; # both x and y for now
999             $self -> _titles;
1000             $self -> _draw_datasets;
1001             $self -> _legends;
1002             $self -> _call_redraw_callback;
1003             }
1004             elsif ($which == 2) # motion, draw box
1005             {
1006             my $e = $self -> XEvent;
1007             $z = $self -> cget('-zoom');
1008             $self -> delete($z -> [4])if ($z -> [4] != 0);
1009             $z -> [4] = $self
1010             -> createRectangle($z -> [0], $z -> [1], $e -> x, $e -> y, '-outline' => 'gray');
1011             $self -> configure('-zoom' => $z);
1012             }
1013             return (1);
1014             }
1015              
1016             sub _create_plot_axis # start and end point of the axis, other args a => b
1017             {
1018             # Optional args -tick
1019             # Optional args -label
1020             # An array containing colour, font and a list of text to display next to
1021             # each tick.
1022             # Optional args -tickFormat
1023             # The sprintf format to use if -label is not provided.
1024             #
1025             # end points are in Canvas pixels
1026             my ($self, $x1, $y1, $x2, $y2, %args) = @_;
1027             my $y_axis = 0;
1028             if ($x1 == $x2)
1029             {
1030             $y_axis = 1;
1031             }
1032             elsif ($y1 != $y2)
1033             {
1034             die 'Cannot determine if X or Y axis desired.'
1035             }
1036              
1037             my $tick = delete $args{-tick};
1038             my $label = delete $args{-label};
1039             my $tick_format = delete $args{-tickFormat};
1040             $tick_format = '%.3g' unless $tick_format;
1041             my ($do_tick, $do_label) = map {ref $_ eq 'ARRAY'} ($tick, $label);
1042              
1043             $self -> createLine($x1, $y1, $x2, $y2, %args);
1044              
1045             if ($do_tick)
1046             {
1047             my ($tcolor, $tfont, $side, $start, $stop, $incr, $delta, $type) = @$tick;
1048             # start, stop are in the world system
1049             # $incr is space between ticks in world coordinates $delta is the number of pixels between ticks
1050             # If type is log then a log axis maybe not
1051             my ($lcolor, $lfont, @labels);
1052             ($lcolor, $lfont, @labels) = @$label if $do_label;
1053             # print "t font <$tfont> l font <$lfont> \n";
1054             my $l;
1055             my $z = 0; # will get $delta added to it, not x direction!
1056             my $tl;
1057             my $an;
1058             if ($y_axis)
1059             {
1060             $tl = $side eq 'w' ? 5 : -6; # tick length
1061             $an = $side eq 'w' ? 'e' : 'w' if $y_axis; #anchor
1062             }
1063             else
1064             {
1065             $tl = $side eq 's' ? 5 : -6; # tick length
1066             $an = $side eq 's' ? 'n' : 's' if not $y_axis;
1067             }
1068             # do the ticks
1069             $incr = 1 if (abs($stop - $start) < 1e-15); # AC: Rounding errors can cause an infinite loop when range is zero!
1070             # This line above fixes this by detecting this case and fixing the increment to 1. (Of course, range should not be zero anyway!)
1071             # print "ticks for loop $l = $start; $l <= $stop; $l += $incr\n"; # DEBUG
1072             for
1073             (
1074             my $l = $start;
1075             ($start <= $stop) ? ($l <= $stop) : ($l >= $stop);
1076             ($start <= $stop) ? ($l += $incr) : ($l -= $incr)
1077             )
1078             {
1079             if ($y_axis)
1080             {
1081             $self -> createLine
1082             (
1083             $x1 - $tl, $y2 - $z, $x1, $y2 - $z,
1084             %args, -fill => $tcolor,
1085             );
1086             }
1087             else
1088             {
1089             $self -> createLine
1090             (
1091             $z + $x1, $y1 + $tl, $z + $x1, $y2,
1092             %args, -fill => $tcolor,
1093             );
1094             }
1095             if ($do_label)
1096             {
1097             my $lbl = shift(@labels);
1098             if ($y_axis)
1099             {
1100             $self -> createText
1101             (
1102             $x1 - $tl, $y2 - $z, -text => $lbl,
1103             %args, -fill => $lcolor,
1104             -font => $lfont, -anchor => $an,
1105             ) if $lbl;
1106             }
1107             else
1108             {
1109             $self -> createText
1110             (
1111             $z + $x1, $y1 + $tl, -text => $lbl,
1112             %args, -fill => $lcolor,
1113             -font => $lfont, -anchor => $an,
1114             ) if $lbl;
1115             }
1116             }
1117             else # default label uses tfont
1118             {
1119             $l = 0 if (($l < 1e-15) and ($l > -1e-15)); # Fix rounding errors at zero.
1120             if ($y_axis)
1121             {
1122             $self -> createText
1123             (
1124             $x1 - $tl, $y2 - $z, -text => sprintf($tick_format, $l),
1125             %args, -fill => $tcolor,
1126             -font => $tfont, -anchor => $an,
1127             );
1128             }
1129             else
1130             {
1131             $self -> createText
1132             (
1133             $z + $x1, $y1 + $tl, -text => sprintf($tick_format, $l),
1134             %args, -fill => $tcolor,
1135             -font => $tfont, -anchor => $an,
1136             );
1137             }
1138             }
1139             ($start <= $stop) ? ($z += $delta) : ($z -= $delta); # only use of delta
1140             }
1141             } # ifend label this axis
1142              
1143             return (1);
1144             } # end _create_plot_axis
1145              
1146             sub _titles
1147             {
1148             # put axis titles and plot title on the plot
1149             # x, y, y1, plot all at once for now
1150             my ($self) = @_;
1151             my $borders = $self -> cget(-border);
1152             my $fonts = $self -> cget('-fonts');
1153             my $w = $self -> width;
1154             my $h = $self -> height;
1155             # y axis
1156             my $y_label = $self -> cget('-ylabel');
1157             my $y_label_pos = $self -> cget('-ylabelPos');
1158             my $y_start = $self -> _center_text_v($borders -> [0], $h - $borders -> [2], $fonts -> [1], $y_label);
1159             $self -> _create_text_v
1160             (
1161             $self -> _to_canvas_pixels('canvas', $borders -> [3] - $y_label_pos, $h - $y_start),
1162             -text => $y_label, -anchor => 's', -font => $fonts -> [1], -tag => 'aaaaa',
1163             );
1164              
1165             # Is y1 axis used for active datasets?
1166              
1167             # y1 axis
1168             my $y1label = $self -> cget('-y1label');
1169             my $y1label_pos = $self -> cget('-y1labelPos');
1170             my $y1start = $self -> _center_text_v($borders -> [0], $h - $borders -> [2], $fonts -> [1], $y1label);
1171             $self -> _create_text_v
1172             (
1173             $self -> _to_canvas_pixels('canvas', $w - $borders -> [1] + $y1label_pos, $h - $y1start),
1174             -text => $y1label, -anchor => 'sw', -font => $fonts -> [1], -tag => 'y1y1y1y1'
1175             ) if ($self -> _count_y1);
1176              
1177             # x axis
1178             my $x_label = $self -> cget('-xlabel');
1179             my $x_label_pos = $self -> cget('-xlabelPos');
1180             my $x_start = $self -> _center_text($borders -> [3], $w - $borders -> [1], $fonts -> [1], $x_label);
1181             $self -> createText
1182             (
1183             $self -> _to_canvas_pixels('canvas', $x_start, $borders -> [2] - $x_label_pos),
1184             -text => $x_label, -anchor => 'sw', -font => $fonts -> [1]
1185             );
1186              
1187             # add a plot title
1188             my $title = $self -> cget('-plotTitle');
1189             $x_start = $self -> _center_text($borders -> [3], $w - $borders -> [1], $fonts -> [2], $title -> [0]);
1190             $self -> createText
1191             (
1192             $self -> _to_canvas_pixels('canvas', $x_start, $h - $borders -> [0] + $title -> [1]),
1193             text => $title -> [0], -anchor => 'nw', -font => $fonts -> [2], -tags => ['title']
1194             );
1195             return (1);
1196             }
1197              
1198             sub _create_text_v # canvas widget, x, y, then all the text arguments plus -scale => number
1199             {
1200             # Writes text from top to bottom.
1201             # For now argument -anchor is removed
1202             # scale is set to 0.75. It the fraction of the previous letter's height that the
1203             # current letter is lowered.
1204             my ($self, $x, $y, %args) = @_;
1205             my $text = delete($args{-text});
1206             my $anchor = delete($args{-anchor});
1207             my $tag = delete($args{-tag});
1208             my @letters = split(//, $text);
1209             # print "args", %args, "\n";;
1210             # OK we know that we have some short and some long letters
1211             # 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
1212             # also g, j, q, and y hang down, the next letter has to be lower
1213             my $th = 0;
1214             my $lc = 0;
1215              
1216             my ($font_width) = $self -> fontMeasure($args{-font}, 'M'); # Measure a wide character to determine the x offset
1217             $x -= $font_width if $anchor =~ /w/; # AC: Implement missing functionality!
1218              
1219             # sorry to say, the height of all the letters as returned by bbox is the same for a given font.
1220             # same is true for the text widget. Nov 2005!
1221             my $letter = shift(@letters);
1222             $self -> createText($x, $y + $th, -text => $letter, -tags => [$tag], %args, -anchor => 'c'); # first letter
1223             my ($min_x, $min_y, $max_x, $max_y) = $self -> bbox($tag);
1224             my $h = $max_y - $min_y;
1225             my $w = $max_x - $min_x;
1226             my $step = 0.80;
1227             $th = $step * $h + $th;
1228             foreach my $letter (@letters)
1229             {
1230             # print "_create_text_v: letter <$letter>\n";
1231             # If the letter is short, move it up a bit.
1232             $th = $th - 0.10 * $h if ($letter =~ /[acegmnoprstuvwxyz.;, :]/); # move up a little
1233             $th = $th - 0.40 * $h if ($letter =~ /[ ]/); # move up a lot
1234             # now write the letter
1235             $self -> createText($x, $y + $th, -text => $letter, -tags => [$tag], %args, -anchor => 'c');
1236             # space for the next letter
1237             $th = $step * $h + $th;
1238             $th = $th + 0.10 * $h if ($letter =~ /[gjpqy.]/); # move down a bit if the letter hangs down
1239             $lc++;
1240             }
1241             return (1);
1242             }
1243              
1244             sub _legends
1245             {
1246             # For all the (active) plots, put a legend
1247             my ($self, %args) = @_;
1248             my $count = 0;
1249             # count the (active) data sets
1250             foreach my $ds (@{$self -> {-datasets}})
1251             {
1252             unless ($ds -> get(-noLegend))
1253             {
1254             $count++ if ($ds -> get('-active') == 1);
1255             }
1256             }
1257             # print "_legends have $count legends to do\n";
1258             my $fonts = $self -> cget('-fonts');
1259              
1260             # Calculate the starting point
1261             my $x_start = 0;
1262             my $y_start = 0;
1263             my $legend_info = $self -> cget('-legendPos');
1264             my $borders = $self -> cget('-border');
1265             if (not defined($legend_info) or $legend_info -> [0] eq 'bottom')
1266             {
1267             $x_start = $borders -> [3];
1268             $y_start = $borders -> [2] - $legend_info -> [1];
1269             }
1270             elsif ($legend_info -> [0] eq 'side')
1271             {
1272             # Find out how big text is
1273             my $test_tag = 'dfjcnjdbnc';
1274             $self -> createText
1275             (
1276             0, 10_000, -text => 'test', -anchor => 'sw', -fill => 'black',
1277             -font => $fonts -> [3], -tags => [$test_tag]
1278             );
1279             my ($text_min_x, $text_min_y, $text_max_x, $text_max_y) = $self -> bbox($test_tag);
1280             my $text_height = $text_max_y - $text_min_y;
1281             $self -> delete($test_tag);
1282              
1283             $x_start = $self -> width - $borders -> [1] + $legend_info -> [1];
1284             $y_start = $self -> height - $borders -> [0] - $text_height;
1285             }
1286             else
1287             {
1288             warn 'Legend position ' . $legend_info -> [0] . "is not valid\n";
1289             }
1290              
1291             my $x_pos = $x_start;
1292             my $y_pos = $y_start;
1293             foreach my $ds (@{$self -> {-datasets}})
1294             {
1295             unless ($ds -> get(-noLegend))
1296             {
1297             if ($ds -> get('-active') != 99) # do them all, not just active
1298             {
1299             my ($x, $y) = $self -> _to_canvas_pixels('canvas', $x_pos, $y_pos);
1300             my $line_tag = $ds -> get('-name');
1301             my $point_tag = $line_tag.'point';
1302             my $tag = $line_tag . 'legend';
1303              
1304             my $fill = $ds -> get('-color');
1305             my $fill_point = $ds -> get('-fillPoint');
1306             my $point_style = $ds -> get('-pointStyle');
1307             my $point_size = $ds -> get('-pointSize');
1308             my $dash = $ds -> get('-dash');
1309             my $text = $ds -> get('-name');
1310              
1311             my $no_line = 0;
1312             if (defined $ds -> get('-lineStyle'))
1313             {
1314             if ($ds -> get('-lineStyle') eq 'none')
1315             {
1316             $no_line = 1;
1317             }
1318             }
1319              
1320             $text = ($ds -> get('-yAxis') eq 'Y1') ? $text . '(Y1) ' : $text . ' ';
1321              
1322             my ($textX, $textY) = $self -> _to_canvas_pixels('canvas', $x_pos + 50, $y_pos);
1323             $self -> createText
1324             (
1325             $textX, $textY,
1326             -text => $text, -anchor => 'sw', -fill => $ds->get('-color'),
1327             -font => $fonts -> [3], -tags => [$tag]
1328             );
1329              
1330             # Find out how big text is
1331             my ($text_min_x, $text_min_y, $text_max_x, $text_max_y) = $self -> bbox($tag);
1332             my $text_height = $text_max_y - $text_min_y;
1333              
1334             # Print line if necessery
1335             if (!$no_line)
1336             {
1337             $self -> createLine
1338             (
1339             $x, $y - $text_height / 2, $x + 40, $y - $text_height / 2, -fill => $fill,
1340             -dash => $dash, -tags => [$tag]
1341             );
1342             }
1343             $self -> _draw_point
1344             (
1345             $x + 20, $y - $text_height / 2, 0, 0,
1346             -fill => $fill, -pointStyle => $point_style, -pointSize => $point_size,
1347             -fillPoint => $fill_point, -tags => [$tag, $point_tag]
1348             );
1349              
1350             # If multiple curves, turn the line and the plot name red when we enter it with the cursor in the legend
1351             if (scalar(@{$self -> {-datasets}}) > 1)
1352             {
1353             $self -> bind
1354             (
1355             $tag, '' => sub
1356             {
1357             # print "Highlighting <$line_tag> and <$tag>.\n";
1358             $self -> itemconfigure($point_tag, -fill => 'red');
1359             $self -> itemconfigure($line_tag, -fill => 'red');
1360             $self -> itemconfigure($tag, -fill => 'red');
1361             }
1362             );
1363             $self -> bind
1364             (
1365             $tag, '' => sub
1366             {
1367             $self -> itemconfigure($line_tag, -fill => $fill);
1368             $self -> itemconfigure($tag, -fill => $fill);
1369             if ($fill_point)
1370             {
1371             $self -> itemconfigure($point_tag, -fill => $fill);
1372             }
1373             else
1374             {
1375             $self -> itemconfigure($point_tag, -fill => '');
1376             }
1377             }
1378             );
1379             }
1380             my ($x1, $y1, $x2, $y2) = $self -> bbox($tag);
1381             if (not defined($legend_info) or $legend_info -> [0] eq 'bottom')
1382             {
1383             if ($x2)
1384             {
1385             $x_pos = $x2 + 10;
1386             if ($y2)
1387             {
1388             # Wrap legend items if they are too wide to fit on the current line
1389             if ($x_pos + ($x2 - $x1) >= $self -> width)
1390             {
1391             $x_pos = $x_start;
1392             $y_pos = $y_pos - ($y2 - $y1);
1393             }
1394             }
1395             }
1396             else
1397             {
1398             $x_pos += 100;
1399             }
1400             }
1401             else
1402             {
1403             if ($y2)
1404             {
1405             $y_pos -= ($y2 - $y1) + 10;
1406             }
1407             else
1408             {
1409             $y_pos -= 100;
1410             }
1411             }
1412             # print "_legends location of last character p1($x1, $y1), p2($x2, $y2)\n";
1413             }
1414             }
1415             }
1416             return (1);
1417             }
1418              
1419             sub addDatasets ## no critic (NamingConventions::ProhibitMixedCaseSubs)
1420             {
1421             # add data sets to the plot object
1422             my ($self, @datasets) = @_;
1423             foreach my $dataset (@datasets)
1424             {
1425             unless (ref($dataset) eq 'LineGraphDataset')
1426             {
1427             warn 'addDatasets: Dataset must be a Tk::LineGraphDataset object'
1428             }
1429             else
1430             {
1431             push @{$self -> {-datasets}}, $dataset;
1432             }
1433             }
1434             return (1);
1435             }
1436              
1437             sub clearDatasets ## no critic (NamingConventions::ProhibitMixedCaseSubs)
1438             {
1439             # removes all data sets from the plot object
1440             my ($self) = @_;
1441             @{$self -> {-datasets}} = ();
1442             return (1);
1443             }
1444              
1445             sub _count_y1
1446             {
1447             # count how many datasets are using y1
1448             my ($self) = @_;
1449             my $count = 0;
1450             foreach my $ds (@{$self -> {-datasets}})
1451             {
1452             $count++ if ($ds -> get('-yAxis') eq 'Y1');
1453             }
1454             # print "_count_y1 <$count>\n";
1455             return ($count);
1456             }
1457              
1458             sub _data_sets_min_max # one argument, all or active
1459             {
1460             # Get the min and max of the datasets
1461             # could be done for all datasets or just the active datasets
1462             # return xmin, xmax, ymin, ymax, y1min, y1max
1463             my ($self, $rescale) = @_;
1464             my $all = 0;
1465             $all = 1 if ($rescale and $rescale eq 'all');
1466             my ($first, $first1) = (0, 0);
1467             my ($y_max, $y_min, $x_max, $x_min, $y_max1, $y_min1) = (0, 0, 0, 0, 0, 0);
1468             my ($x_data, $y_data, $y_error);
1469             # Do x then y and y1
1470             foreach my $ds (@{$self -> {-datasets}})
1471             {
1472             if ($all or ($ds -> get('-active') == 1))
1473             {
1474             $y_data = $ds -> get('-yData');
1475             $x_data = $ds -> get('-xData');
1476             $x_data = [0..scalar(@$y_data) - 1] unless (defined($x_data));
1477             if ($first == 0)
1478             {
1479             $x_max = $x_min = $x_data -> [0];
1480             $first = 1;
1481             }
1482             foreach my $e (@{$x_data})
1483             {
1484             $x_max = $e if ($e > $x_max );
1485             $x_min = $e if ($e < $x_min );
1486             }
1487             }
1488             }
1489             $first = $first1 = 0;
1490             foreach my $ds (@{$self -> {-datasets}})
1491             {
1492             if ($all or ($ds -> get('-active') == 1))
1493             {
1494             my $a = 0;
1495              
1496             $y_data = $ds -> get('-yData');
1497             $y_error = $ds -> get('-yError');
1498              
1499             if ($ds -> get('-yAxis') eq 'Y1')
1500             {
1501             if ($first1 == 0)
1502             {
1503             $y_max1 = $y_min1 = $y_data -> [0];
1504             $first1 = 1;
1505             }
1506              
1507             foreach my $e (@{$y_data})
1508             {
1509             $y_max1 = $e if ($e > $y_max1);
1510             $y_min1 = $e if ($e < $y_min1);
1511              
1512             if ($y_error)
1513             {
1514             # Make all error values positive
1515             $y_max1 = $e + abs($y_error -> [$a]) if ($e + abs($y_error -> [$a]) > $y_max1);
1516             $y_min1 = $e - abs($y_error -> [$a]) if ($e - abs($y_error -> [$a]) < $y_min1);
1517             $a++;
1518             }
1519             }
1520             }
1521             else
1522             { # for y axis
1523             if ($first == 0)
1524             {
1525             $y_max = $y_min = $y_data -> [0];
1526             $first = 1;
1527             }
1528              
1529             foreach my $e (@{$y_data})
1530             {
1531             $y_max = $e if ($e > $y_max);
1532             $y_min = $e if ($e < $y_min);
1533              
1534             if ($y_error)
1535             {
1536             # Make all error values positive
1537             $y_max = $e+abs($y_error->[$a]) if ($e+abs($y_error->[$a]) > $y_max);
1538             $y_min = $e-abs($y_error->[$a]) if ($e-abs($y_error->[$a]) < $y_min);
1539             $a++;
1540             }
1541             }
1542             }
1543             }
1544             }
1545             # print "_data_sets_min_max: X($x_min, $x_max), Y($y_min, $y_max), Y1($y_min1, $y_max1)\n";
1546             return ($x_min, $x_max, $y_min, $y_max, $y_min1, $y_max1);
1547             }
1548              
1549             sub _scale_plot # 'all' or 'active'
1550             {
1551             # scale either all the data sets or just the active ones
1552             my ($self, $how) = @_;
1553             my ($x_min, $x_max, $y_min, $y_max, $y1min, $y1max) = $self -> _data_sets_min_max($how);
1554             # print "_scale_plot: min and max ($x_min, $x_max), ($y_min, $y_max), ($y1min, $y1max)\n";
1555             my ($x_tick_labels, $y_tick_labels, $y1_tick_labels);
1556             my ($y_min_p, $y_max_p, $y_intervals);
1557             my $scale = $self -> cget(-scale);
1558             if ($self -> cget(-autoScaleY) eq 'On')
1559             {
1560             ($y_min_p, $y_max_p, $y_intervals) = _nice_range($y_min, $y_max);
1561             if ($self -> cget('-yType') eq 'log')
1562             {
1563             ($y_min_p, $y_max_p, $y_intervals, $y_tick_labels) = $self -> _log_range
1564             (
1565             $y_min, $y_max,
1566             -tickFormat => $self -> cget('-yTickFormat')
1567             );
1568             }
1569             }
1570             else
1571             {
1572             ($y_min_p, $y_max_p, $y_intervals) = ($scale -> [3], $scale -> [4], $scale -> [5]);
1573             }
1574             my ($y1min_p, $y1max_p, $y1intervals);
1575             if ($self -> cget(-autoScaleY1) eq 'On')
1576             {
1577             ($y1min_p, $y1max_p, $y1intervals) = _nice_range($y1min, $y1max);
1578             if ($self -> cget('-y1Type') eq 'log')
1579             {
1580             ($y1min_p, $y1max_p, $y1intervals, $y1_tick_labels) = $self -> _log_range
1581             (
1582             $y1min, $y1max,
1583             -tickFormat => $self -> cget('-y1TickFormat')
1584             );
1585             }
1586             }
1587             else
1588             {
1589             ($y1min_p, $y1max_p, $y1intervals) = ($scale -> [6], $scale -> [7], $scale -> [8]);
1590             }
1591             my ($x_min_p, $x_max_p, $x_intervals);
1592             if ($self -> cget(-autoScaleX) eq 'On')
1593             {
1594             ($x_min_p, $x_max_p, $x_intervals) = _nice_range($x_min, $x_max);
1595             if ($self -> cget('-xType') eq 'log')
1596             {
1597             ($x_min_p, $x_max_p, $x_intervals, $x_tick_labels) = $self -> _log_range
1598             (
1599             $x_min, $x_max,
1600             -tickFormat => $self -> cget('-xTickFormat')
1601             );
1602             }
1603             }
1604             else
1605             {
1606             ($x_min_p, $x_max_p, $x_intervals) = ($scale -> [0], $scale -> [1], $scale -> [2]);
1607             }
1608             # print "_scale_plot: $y_min_p, $y_max_p, $y_intervals, @$y_tick_labels\n";
1609             # print "($x_min_p, $x_max_p, $x_intervals) tickLabels <$x_tick_labels> \n";
1610             $self -> configure(-xTickLabel => $x_tick_labels);
1611             $self -> configure(-yTickLabel => $y_tick_labels);
1612             $self -> configure(-y1TickLabel => $y1_tick_labels);
1613             # print "_scale_plot: Y $y_min_p, $y_max_p, $y_intervals X $x_min_p, $x_max_p, $x_intervals \n";
1614             # put these scale values into the plot widget
1615             $self -> configure
1616             (
1617             -scale =>
1618             [
1619             $x_min_p, $x_max_p, $x_intervals,
1620             $y_min_p, $y_max_p, $y_intervals,
1621             $y1min_p, $y1max_p, $y1intervals
1622             ]
1623             );
1624             # print "in scale $y_min_p, $y_max_p, $y_intervals \n";
1625             # reset the zoom stack!
1626             $self -> {-zoomStack} = [];
1627             return (1);
1628             }
1629              
1630             sub plot
1631             {
1632             # plot all the active data sets
1633             # 'always' (Default), 'never' or 'not_zoomed'
1634             my ($self, $rescale) = @_;
1635             $rescale = 'always' unless defined($rescale); # Default to Always
1636              
1637             if ($rescale eq 'always') # Always Rescale
1638             {
1639             $self -> _rescale('all');
1640             }
1641             elsif ($rescale eq 'never') # Never Rescale
1642             {
1643             $self -> _rescale('not');
1644             }
1645             elsif ($rescale eq 'not_zoomed') # Only Rescale if not Zoomed in
1646             {
1647             if (@{$self -> {-zoomStack}} == 0)
1648             {
1649             $self -> _rescale('all');
1650             }
1651             else
1652             {
1653             $self -> _rescale('not');
1654             }
1655             }
1656              
1657             return (1);
1658             }
1659              
1660             sub _draw_axis
1661             {
1662             # do both of the axis
1663             my ($self) = @_;
1664             my $s = $self -> cget(-scale); # get the scale factors
1665             my ($nb, $eb, $sb, $wb) = @{$self -> cget(-border)};
1666             # for now, figure this will fit
1667             my $h = $self -> height;
1668             my $w = $self -> width;
1669             my $x_tick_label = $self -> cget('-xTickLabel');
1670             my $fonts = $self -> cget('-fonts');
1671             # print "_draw_axis: xTickLabel <$x_tick_label>\n";
1672             my $lab = [];
1673             if ($x_tick_label)
1674             {
1675             # print "draw axis: making tick labels\n";
1676             push (@{$lab}, 'black', $fonts -> [0]);
1677             foreach my $tl (@{$x_tick_label})
1678             {
1679             push @{$lab}, $tl;
1680             # print "_draw_axis: @{$lab} \n";
1681             }
1682             }
1683             else
1684             {
1685             $lab = undef;
1686             }
1687              
1688             # xAxis first
1689             # tick stuff
1690             my ($t_start, $t_stop, $interval) = ($s -> [0], $s -> [1], abs($s -> [2]));
1691             my $ticks = ($t_stop - $t_start) / $interval;
1692             my $a_length = $w - $wb - $eb;
1693             my $d = $a_length / $ticks;
1694             my ($x_start, $y_start, $x_end, $y_end) = ($wb, $h - $sb, $w - $eb, $h - $sb);
1695             my $result = $self -> _create_plot_axis
1696             (
1697             $x_start, $y_start, $x_end, $y_end,
1698             -fill => 'black',
1699             # $tcolor, $tfont, $side, $start, $stop, $incr, $delta)
1700             # incr step size - used in lable in PIXELS, delta is the PIXELS between ticks
1701             # have to start at the start of the "axis". Not good!
1702             -tick => ['black', $fonts -> [0], 's', $t_start, $t_stop, $interval, $d],
1703             -tickFormat => $self -> cget('-xTickFormat'),
1704             -label => $lab,
1705             );
1706              
1707             # box x axis
1708             ($x_start, $y_start, $x_end, $y_end) = ($wb, $nb, $w - $eb, $nb);
1709             $result = $self -> _create_plot_axis
1710             (
1711             $x_start, $y_start, $x_end, $y_end,
1712             -fill => 'black'
1713             );
1714              
1715             # setup the tick labels if they have been set
1716             my $y_tick_label = $self -> cget('-yTickLabel');
1717             $lab = [];
1718             if ($y_tick_label)
1719             {
1720             # print "_draw_axis: making tick labels for y\n";
1721             push @{$lab}, 'black', $fonts -> [0] ;
1722             foreach my $tl (@{$y_tick_label})
1723             {
1724             push @{$lab}, $tl;
1725             # print "_draw_axis: @{$lab} \n";
1726             }
1727             }
1728             else
1729             {
1730             $lab = undef;
1731             }
1732             # print "y axis label <$lab> \n";
1733             #YAxis now
1734             ($x_start, $y_start, $x_end, $y_end) = ($wb, $nb, $wb, $h-$sb);
1735             ($t_start, $t_stop, $interval) = ($s -> [3], $s -> [4], abs($s -> [5]));
1736             $interval = 10 if ($interval <= 0);
1737             $ticks = ($t_stop - $t_start) / $interval;
1738             $a_length = $h - $nb - $sb;
1739             $d = $a_length / $ticks;
1740             $result = $self -> _create_plot_axis
1741             (
1742             $x_start, $y_start, $x_end, $y_end,
1743             -fill => 'black',
1744             # $tcolor, $tfont, $side, $start, $stop, $incr, $delta)
1745             # incr step size - used in lable in PIXELS, delta is the PIXELS between ticks
1746             # have to start at the start of the "axis". Not good!
1747             -tickFormat => $self -> cget('-yTickFormat'),
1748             -tick => ['black', $fonts -> [0], 'w', $t_start, $t_stop, $interval, $d],
1749             -label => $lab,
1750             );
1751              
1752             #Y1Axis now if needed
1753             if ($self -> _count_y1)
1754             {
1755             # setup the tick labels if they have been set
1756             my $y1_tick_label = $self -> cget('-y1TickLabel');
1757             $lab = [];
1758             if ($y1_tick_label)
1759             {
1760             # print "_draw_axis: making tick labels for y\n";
1761             push (@{$lab}, 'black', $fonts -> [0]);
1762             foreach my $tl (@{$y1_tick_label})
1763             {
1764             push (@{$lab}, $tl);
1765             # print "_draw_axis: @{$lab} \n";
1766             }
1767             }
1768             else
1769             {
1770             $lab = undef;
1771             }
1772             ($x_start, $y_start, $x_end, $y_end) = ($w-$eb, $nb, $w-$eb, $h-$sb);
1773             ($t_start, $t_stop, $interval) = ($s -> [6], $s -> [7], abs($s -> [8]));
1774             $interval = 10 if ($interval <= 0);
1775             $ticks = ($t_stop - $t_start) / $interval;
1776             $a_length = $h - $nb - $sb;
1777             $d = ($ticks != 0) ? $a_length / $ticks : 1;
1778             $result = $self -> _create_plot_axis
1779             (
1780             $x_start, $y_start, $x_end, $y_end,
1781             -fill => 'black',
1782             # $tcolor, $tfont, $side, $start, $stop, $incr, $delta)
1783             # incr step size - used in lable in PIXELS, delta is the PIXELS between ticks
1784             # have to start at the start of the "axis". Not good!
1785             -tick => ['black', $fonts -> [0], 'e', $t_start, $t_stop, $interval, $d],
1786             -tickFormat => $self -> cget('-y1TickFormat'),
1787             -label => $lab,
1788             );
1789             }
1790             # box y axis
1791             ($x_start, $y_start, $x_end, $y_end) = ($w-$eb, $nb, $w-$eb, $h-$sb);
1792             $result = $self -> _create_plot_axis
1793             (
1794             $x_start, $y_start, $x_end, $y_end,
1795             -fill => 'black',
1796             );
1797             $self -> _log_ticks;
1798             return (1);
1799             }
1800              
1801             sub _log_ticks
1802             {
1803             # put the 2, 3, 4, ..., 9 ticks on a log axis
1804             my ($self) = @_;
1805             my $s = $self -> cget('-scale');
1806             my ($h, $w) = ($self -> height, $self -> width);
1807             my $borders = $self -> cget('-border');
1808             # do x axis
1809             if ($self -> cget('-xType') eq 'log')
1810             {
1811             my ($min_p, $max_p, $delta_p) = ($s -> [0], $s -> [1], $s -> [2]);
1812             my $dec = ($max_p - $min_p);
1813             unless ($dec > 5) # only if there are less than four decades
1814             {
1815             my $axis_length = $w - $borders -> [1] - $borders -> [3];
1816             my $d_length = $axis_length / ($max_p - $min_p);
1817             my $delta;
1818             my $y = $h - $borders -> [2];
1819             foreach my $ii (1..$dec)
1820             {
1821             foreach my $i (2..9)
1822             {
1823             my $delta = (log10 $i) * $d_length;
1824             my $x = ($borders -> [3]) + $delta + $d_length * ($ii - 1);
1825             # print "_log_ticks: $ii $i delta $delta y $y \n";
1826             $self -> createLine($x, $y, $x, $y + 6, -fill => 'black');
1827             }
1828             } # end each decade
1829             }
1830             }
1831             # do y axis
1832             if ($self -> cget('-yType') eq 'log')
1833             {
1834             my ($min_p, $max_p, $delta_p) = ($s -> [3], $s -> [4], $s -> [5]);
1835             my $dec = ($max_p - $min_p);
1836             unless ($dec > 5) # only if there are less than four decades
1837             {
1838             my $axis_length = $h - $borders -> [0] - $borders -> [2];
1839             my $d_length = $axis_length / ($max_p - $min_p);
1840             my $delta;
1841             foreach my $ii (1..$dec)
1842             {
1843             foreach my $i (2..9)
1844             {
1845             my $delta = (log10 $i) * $d_length;
1846             my $y = $h - ($borders -> [2]) - $delta - $d_length * ($ii - 1);;
1847             # print "_log_ticks: $ii $i delta $delta y $y \n";
1848             $self -> createLine($borders -> [3], $y, $borders -> [3] + 6, $y, -fill => 'black');
1849             }
1850             } # end each decade
1851             }
1852             }
1853             # do y1 axis
1854             if ($self -> cget('-y1Type') eq 'log')
1855             {
1856             my ($min_p, $max_p, $delta_p) = ($s -> [6], $s -> [7], $s -> [8]);
1857             my $dec = ($max_p - $min_p);
1858             unless ($dec > 5) # only if there are less than four decades
1859             {
1860             my $axis_length = $h - $borders -> [0] - $borders -> [2];
1861             my $d_length = $axis_length / ($max_p - $min_p);
1862             my $delta;
1863             foreach my $ii (1..$dec)
1864             {
1865             foreach my $i (2..9)
1866             {
1867             my $delta = (log10 $i) * $d_length;
1868             my $x = $self -> width - $borders -> [1];
1869             my $y = $h - ($borders -> [2]) - $delta - $d_length * ($ii - 1);
1870             # print "_log_ticks: $ii $i delta $delta y $y \n";
1871             $self -> createLine($x, $y, $x - 6, $y, -fill => 'black');
1872             }
1873             } # end each decade
1874             }
1875             }
1876             return (1);
1877             }
1878              
1879             sub _draw_datasets
1880             {
1881             # draw the line(s) for all active datasets
1882             my ($self, @args) = @_;
1883             %{$self -> {BalloonPoints}} = (); # Clear the balloon help hash before drawing.
1884             foreach my $ds (@{$self -> {-datasets}})
1885             {
1886             if ($ds -> get('-active') == 1)
1887             {
1888             $self -> _draw_one_dataset($ds);
1889             }
1890             }
1891             return (1);
1892             }
1893              
1894             sub _draw_one_dataset # index of the dataset to draw, widget args
1895             {
1896             # draw even if not active ?
1897             my ($self, $ds, %args) = @_;
1898             # %args seems not to be used here.
1899             my ($nb, $eb, $sb, $wb) = @{$self -> cget(-border)};
1900             my $tag = $ds -> get('-name');
1901             my $fill;
1902             my $index = $ds -> get('-index');
1903             if ($ds -> get('-color') eq 'none')
1904             {
1905             my $colors = $self -> cget(-colors);
1906             $fill = $self -> cget('-colors') -> [$index % @$colors];
1907             $ds -> set('-color' => $fill);
1908             }
1909             else
1910             {
1911             $fill = $ds -> get('-color');
1912             }
1913              
1914             my $line_style = $ds -> get('-lineStyle'); #SS - added option to set line style
1915             my $no_line = 0;
1916             my $dash = '';
1917             if ($line_style)
1918             {
1919             if ($line_style eq 'none')
1920             {
1921             $no_line = 1;
1922             }
1923             elsif ($line_style eq 'normal')
1924             {
1925             $dash = '';
1926             }
1927             elsif ($line_style eq 'dot')
1928             {
1929             $dash = '.';
1930             }
1931             elsif ($line_style eq 'dash')
1932             {
1933             $dash = '-';
1934             }
1935             elsif ($line_style eq 'dotdash')
1936             {
1937             $dash = '.-';
1938             }
1939             else
1940             {
1941             warn "Invalid -lineStyle setting ($line_style) on line $tag, defaulting to normal\n";
1942             $ds -> set('-lineStyle' => 'normal');
1943             }
1944             $ds -> set('-dash' => $dash);
1945             }
1946             else
1947             {
1948             $dash = '';
1949             $ds -> set('-dash' => $dash);
1950             $ds -> set('-lineStyle' => 'normal');
1951             }
1952              
1953             my $point_style; #SS - added option to set point style
1954             if (!$ds -> get('-pointStyle'))
1955             {
1956             my $point_styles = $self -> cget('-pointShapes');
1957             $point_style = $point_styles -> [$index % @$point_styles];
1958             $ds -> set('-pointStyle' => $point_style);
1959             }
1960             else
1961             {
1962             $point_style = $ds -> get('-pointStyle');
1963             }
1964              
1965             my $point_size = $ds -> get('-pointSize'); #SS - added option to set point style
1966             if (!$point_size)
1967             {
1968             $point_size = 3;
1969             $ds -> set('-pointSize' => $point_size);
1970             }
1971              
1972             my $fill_point = $ds -> get('-fillPoint'); #SS - added option to set whether point should be filled
1973             if (! defined $fill_point)
1974             {
1975             $fill_point = 1;
1976             $ds -> set('-fillPoint' => $fill_point);
1977             }
1978              
1979             my $yax = $ds -> get('-yAxis'); # does this dataset use y or y1 axis
1980             # print "_draw_one_dataset: index <$index> color <$fill> y axis <$yax>\n";
1981             my $y_data = $ds -> get('-yData');
1982             my $x_data = $ds -> get('-xData');
1983             $x_data = [0..(scalar(@$y_data)-1)] unless (defined($x_data));
1984             my $y_error = $ds -> get('-yError');
1985              
1986             my $log_min = $self -> cget(-logMin);
1987             my $x = [];
1988             # if x-axis uses a log scale convert x data
1989             if ($self -> cget('-xType') eq 'log')
1990             {
1991             foreach my $e (@{$x_data})
1992             {
1993             $e = $log_min if ($e <= 0);
1994             push @{$x}, log10($e);
1995             } # end foreach
1996             }
1997             else # not log at all
1998             {
1999             $x = $x_data;
2000             }
2001             my $y = [];
2002             # just maybe we have a log plot to do. In that case must take the log of each point
2003             if
2004             (
2005             (($yax eq 'Y1') and ($self -> cget('-y1Type') eq 'log'))
2006             or (($yax eq 'Y') and ($self -> cget('-yType') eq 'log'))
2007             )
2008             {
2009             foreach my $e (@{$y_data})
2010             {
2011             $e = $log_min if ($e <= 0);
2012             push @{$y}, log10($e);
2013             } # end foreach
2014             }
2015             else # not log at all
2016             {
2017             $y = $y_data;
2018             }
2019              
2020             my $dy = [];
2021             if ($y_error)
2022             {
2023             my $a = 0;
2024              
2025             # in case we have a log plot to do we have to log the errors as well
2026             if
2027             (
2028             (($yax eq 'Y1') and ($self -> cget('-y1Type') eq 'log'))
2029             or (($yax eq 'Y') and ($self -> cget('-yType') eq 'log'))
2030             )
2031             {
2032             foreach my $e (@{$y_error})
2033             {
2034             # error values on log scale are larger below the point than above, i.e. we implement the concept of
2035             # plus and minus error already here by building absolute values (y+dy; y-dy) and going on with them;
2036             # just use positive errors
2037              
2038             $dy -> [0] -> [$a] = log10($y_data -> [$a] + abs($e)); # pluserror
2039              
2040             # if minuserror is below 0 trim to log_min
2041             my $tmp;
2042             if ($y_data -> [$a] - abs($e) <= 0)
2043             {
2044             $tmp = $log_min;
2045             }
2046             else
2047             {
2048             $tmp = $y_data -> [$a] - abs($e);
2049             }
2050              
2051             $dy -> [1] -> [$a] = log10($tmp); # minuserror
2052             $a++;
2053             }
2054             }
2055             else # not log at all
2056             {
2057             foreach my $e (@{$y_error})
2058             {
2059             $dy -> [0] -> [$a] = $y_data -> [$a] + abs($e);
2060             $dy -> [1] -> [$a] = $y_data -> [$a] - abs($e);
2061             $a++;
2062             }
2063             }
2064             }
2065              
2066             # need to make one array out of two
2067             my @xy_points;
2068              
2069             my @all_data;
2070             my $dyp = [];
2071             my $dym = [];
2072              
2073             # right here we need to go from data set coordinates to plot PIXEL coordinates
2074             my ($xReady, $yReady, $dyplusReady, $dyminusReady) = $self -> _ds_to_plot_pixels($x, $y, $dy, $yax);
2075             (@all_data) = $self -> _arrays_to_canvas_pixels('axis', $xReady, $yReady, $dyplusReady, $dyminusReady);
2076              
2077             # all data contains xy_points and plus and minus errors
2078             for (my $a = 0; $a < (@all_data/4); $a++)
2079             {
2080             $xy_points[$a * 2] = $all_data[$a * 4];
2081             $xy_points[$a * 2 + 1] = $all_data[$a * 4 + 1];
2082             $dyp -> [$a] = $all_data[$a * 4 + 2];
2083             $dym -> [$a] = $all_data[$a * 4 + 3];
2084             }
2085              
2086             # got to take care of the case where the data set is empty or just one point.
2087             return if (@xy_points == 0);
2088             if (@xy_points == 2)
2089             {
2090             # print "one point, draw a dot!\n";
2091             my ($xa, $ya) = ($xy_points[0], $xy_points[1]);
2092              
2093             $self -> _draw_point
2094             (
2095             $xa, $ya, $dyp -> [0], $dym -> [0], -pointStyle => $point_style, -pointSize => $point_size,
2096             -fillPoint => $fill_point, -fill => $fill, -tags => [$tag, $tag . 'point']
2097             );
2098             }
2099             else
2100             {
2101             $self -> _draw_one_dataset_b
2102             (
2103             -data => \@xy_points,
2104             -fill => $fill,
2105             -dash => $dash,
2106             -tags => [$tag],
2107             -xData => $x_data,
2108             -yData => $y_data,
2109             -yError => [$dyp, $dym],
2110             -noLine => $no_line,
2111             -pointStyle => $point_style,
2112             -pointSize => $point_size,
2113             -fillPoint => $fill_point
2114             );
2115             }
2116              
2117             # If multiple curves, turn the plot name in the legend and the line red when we enter the line with the cursor
2118             if (scalar(@{$self -> {-datasets}}) > 1)
2119             {
2120             $self -> bind
2121             (
2122             $tag, '' => sub
2123             {
2124             $self -> itemconfigure($tag, -fill => 'red');
2125             $self -> itemconfigure($tag . 'legend', -fill => 'red');
2126             $self -> itemconfigure($tag . 'point', -fill => 'red');
2127             }
2128             );
2129             $self -> bind
2130             (
2131             $tag, '' => sub
2132             {
2133             $self -> itemconfigure($tag, -fill => $fill);
2134             $self -> itemconfigure($tag . 'legend', -fill => $fill);
2135             if ($fill_point)
2136             {
2137             $self -> itemconfigure($tag . 'point', -fill => $fill);
2138             }
2139             else
2140             {
2141             $self -> itemconfigure($tag . 'point', -fill => '');
2142             }
2143             }
2144             );
2145             }
2146             return (1);
2147             }
2148              
2149             sub _center_text_v # given y1, y2, a font and a string
2150             {
2151             # return a y value for the start of the text
2152             # The system is in canvas, that is 0, 0 is top right.
2153             # return -1 if the text will just not fit
2154             my ($self, $y1, $y2, $f, $s) = @_;
2155             return (-1) if ($y1 > $y2);
2156             my $g = 'gowawyVVV';
2157             $self -> _create_text_v
2158             (
2159             0, 10_000, -text => $s, -anchor => 'sw',
2160             -font => $f, -tag => $g
2161             );
2162             my ($min_x, $min_y, $max_x, $max_y) = $self -> bbox($g);
2163             # print "_center_text_v: ($min_x, $min_y, $max_x, $max_y)\n";
2164             $self -> delete($g);
2165             my $space = $y2 - $y1;
2166             my $str_length = $max_y - $min_y;
2167             return (-1) if ($str_length > $space);
2168             # print "_center_text_v: $y1, $y2, space $space, strLen $str_length\n";
2169             return (($y1 + $y2 - $str_length) / 2);
2170             }
2171              
2172             sub _center_text # x1, x2 a font and a string
2173             {
2174             # return the x value fo where to start the text to center it
2175             # forget about leading and trailing blanks!!!!
2176             # Return -1 if the text will not fit
2177             my ($self, $x1, $x2, $f, $s) = @_;
2178             return (-1) if ($x1 > $x2);
2179             my $g = 'gowawy';
2180             $self -> createText
2181             (
2182             0, 10_000, -text => $s, -anchor => 'sw',
2183             -font => $f, -tags => [$g]
2184             );
2185             my ($min_x, $min_y, $max_x, $max_y) = $self -> bbox($g);
2186             $self -> delete($g);
2187             my $space = $x2-$x1;
2188             my $str_length = $max_x - $min_x;
2189             return (-1) if ($str_length > $space);
2190             return (($x1 + $x2 - $str_length) / 2);
2191             }
2192              
2193             sub _draw_one_dataset_b # takes same arguments as createLinePlot confused
2194             {
2195             # do clipping if needed
2196             # do plot with dots if needed
2197             my ($self, %args) = @_;
2198             my $xy_points = delete($args{'-data'});
2199             my $x_data = delete($args{'-xData'}); # Take the original data for use
2200             my $y_data = delete($args{'-yData'}); # in the balloon popups
2201             my $y_error = delete($args{'-yError'}); # and y errors if given
2202             my $no_line = delete($args{'-noLine'}); # Add a switch to allow points-only plots
2203             my $point_style = delete($args{'-pointStyle'}); # Add a switch to set point style
2204             my $point_size = delete($args{'-pointSize'}); # Add a switch to set point size
2205             my $fill_point = delete($args{'-fillPoint'}); # Add a switch to specify points as not filled
2206             # $self -> createLinePlot(-data => $xy_points, %args);
2207             $self -> _clip_plot(-data => $xy_points, %args) unless $no_line;
2208             my $h = $self -> height;
2209             my $w = $self -> width;
2210             my $borders = $self -> cget(-border);
2211             # Data points are only shown if the dataset has no line or the number of
2212             # points on the plot is less then or equal to the -maxPoints option
2213             my $points = @{$xy_points} / 2;
2214             my $inPoints = $self -> _count_in_points($xy_points);
2215             if (($inPoints <= $self -> cget(-maxPoints)) or $no_line)
2216             {
2217             my $tags = $args{'-tags'};
2218             my $mainTag = $$tags[0];
2219             for (my $i = 0; $i < $points; $i++)
2220             {
2221             my $specificPointTag = $mainTag . "($i)";
2222             my $generalPointTag = $mainTag . 'point';
2223             my @pointTags = (@$tags, $specificPointTag, $generalPointTag);
2224             my ($x, $y, $dyp, $dym) = (0, 0, 0, 0);
2225             ($x, $y, $dyp, $dym) =
2226             (
2227             $xy_points -> [$i * 2], $xy_points -> [$i * 2 + 1],
2228             $y_error -> [0] -> [$i], $y_error -> [1] -> [$i]
2229             );
2230              
2231             if ($self -> cget('-balloons'))
2232             {
2233             $self -> {BalloonPoints} -> {$specificPointTag}
2234             = sprintf('%.3g, %.3g', $$x_data[$i], $$y_data[$i]);
2235             }
2236             if
2237             (
2238             ($x >= $borders -> [3])
2239             and ($x <= ($w - $borders -> [1]))
2240             and ($y >= $borders -> [0])
2241             and ($y <= ($h - $borders -> [2]))
2242             )
2243             {
2244             $self -> _draw_point
2245             (
2246             $x, $y, $dyp, $dym, %args, -pointStyle => $point_style, -pointSize => $point_size,
2247             -fillPoint => $fill_point, -tags => \@pointTags
2248             )
2249             }
2250             }
2251             }
2252             return (1);
2253             }
2254              
2255             sub _draw_point
2256             {
2257             # Draws a point (includes drawing and clipping of error bars).
2258             my ($self, $x, $y, $dyp, $dym, %args) = @_;
2259              
2260             my $point_style = delete($args{-pointStyle});
2261             my $point_size = delete($args{-pointSize});
2262             my $fill_point = delete($args{-fillPoint});
2263             my $fill = $args{-fill};
2264              
2265             my $h = $self -> height;
2266             my $w = $self -> width;
2267             my $borders = $self -> cget(-border);
2268             my $pluserror = -1;
2269             my $minuserror = -1;
2270             if
2271             (
2272             ($x >= $borders -> [3])
2273             and ($x <= ($w - $borders -> [1]))
2274             and ($y >= $borders -> [0])
2275             and ($y <= ($h - $borders -> [2]))
2276             )
2277             {
2278             if (($dym) >= ($h - $borders->[2]))
2279             {
2280             # The error bar exceeds the lower border -> trim it;
2281             $minuserror = ($h - $borders->[2]);
2282             }
2283             if (($dyp) <= $borders -> [0])
2284             {
2285             # The error bar exceeds the upper border -> trim it;
2286             $pluserror = $borders->[0];
2287             }
2288             }
2289              
2290             # widths of error bar ends (coupled to point size)
2291             my $pluswidth = 0;
2292             my $minuswidth = 0;
2293              
2294             my $default_width = 3 + $point_size - 1.5;
2295             my $default_thickness = (1 + $point_size - 1.5) * 0.5;
2296              
2297             if ($minuserror == -1)
2298             {
2299             $minuserror = $dym; # keep default error bar
2300             $minuswidth = $default_width unless ($dym == $y); # if error=0 de facto no error bar
2301             }
2302              
2303             if ($pluserror == -1)
2304             {
2305             $pluserror = $dyp;
2306             $pluswidth = $default_width unless ($dyp == $y);
2307             }
2308              
2309             # draw error bars if not globally switched off
2310             if (($self -> cget('-showError')) && ($dyp != 0) && ($dym != 0))
2311             {
2312             $self -> createLine
2313             (
2314             $x, $minuserror, $x, $pluserror, -width => $default_thickness, %args
2315             );
2316             $self -> createLine
2317             (
2318             $x-$pluswidth, $pluserror, $x+$pluswidth, $pluserror, -width => $default_thickness, %args
2319             );
2320             $self -> createLine
2321             (
2322             $x-$minuswidth, $minuserror, $x+$minuswidth, $minuserror, -width => $default_thickness, %args
2323             );
2324             }
2325              
2326             unless ($point_style)
2327             {
2328             $point_style = '';
2329             }
2330              
2331             unless ($point_size)
2332             {
2333             warn "_draw_point: No point size specified for $args{-tags} -> [0]\n";
2334             $point_size = 3;
2335             }
2336              
2337             $args{-outline} = $args{-fill};
2338             unless ($fill_point)
2339             {
2340             $args{-fill} = '';
2341             }
2342              
2343             if ($point_style eq 'none')
2344             {
2345             }
2346             elsif ($point_style eq 'circle' or $point_style eq '')
2347             {
2348             $self -> createOval
2349             (
2350             $x - $point_size, $y - $point_size,
2351             $x + $point_size, $y + $point_size, %args
2352             );
2353             }
2354             elsif ($point_style eq 'square')
2355             {
2356             $self -> createRectangle
2357             (
2358             $x - $point_size, $y - $point_size,
2359             $x + $point_size, $y + $point_size, %args
2360             );
2361             }
2362             elsif ($point_style eq 'triangle')
2363             {
2364             $self -> createPolygon
2365             (
2366             $x - $point_size, $y - $point_size,
2367             $x + $point_size, $y - $point_size,
2368             $x, $y + $point_size, %args
2369             );
2370             }
2371             elsif ($point_style eq 'diamond')
2372             {
2373             $self -> createPolygon
2374             (
2375             $x - $point_size, $y,
2376             $x, $y + $point_size,
2377             $x + $point_size, $y,
2378             $x, $y - $point_size, %args
2379             );
2380             }
2381             else
2382             {
2383             warn "_draw_point: Point style $point_style is invalid, line = $args{-tags} -> [0]\n";
2384             $self -> createOval
2385             (
2386             $x - $point_size, $y - $point_size,
2387             $x + $point_size, $y + $point_size, %args
2388             );
2389             }
2390             return (1);
2391             }
2392              
2393             sub _count_in_points # array of x, y points
2394             {
2395             # count the points inside the plot box.
2396             my ($self, $xy_points) = @_;
2397             my $points = @{$xy_points} / 2;
2398             my $count = 0;
2399             my $h = $self -> height;
2400             my $w = $self -> width;
2401             my $borders = $self -> cget(-border);
2402              
2403             for (my $i = 0; $i < $points; $i++)
2404             {
2405             my ($x, $y) = ($xy_points -> [$i * 2], $xy_points -> [$i * 2 + 1]);
2406             if
2407             (
2408             ($x >= $borders -> [3])
2409             and ($x <= ($w - $borders -> [1]))
2410             and ($y >= $borders -> [0])
2411             and ($y <= ($h - $borders -> [2]))
2412             )
2413             {
2414             $count++;
2415             }
2416             }
2417             return ($count);
2418             }
2419              
2420             sub _clip_plot # -data => array ref which contains x, y points in Canvas pixels
2421             {
2422             # draw a multi point line but cliped at the borders
2423             my ($self, %args) = @_;
2424             my $xy_points = delete($args{'-data'});
2425             my $point_count = (@{$xy_points})/2;
2426             my $h = $self -> height;
2427             my $w = $self -> width;
2428             my $last_point = 1; # last pointed plotted is flaged as being out of the plot box
2429             my $borders = $self -> cget(-border);
2430             my @p; # a new array with points for line segment to be plotted
2431             my ($x, $y);
2432             my ($xp, $yp) = ($xy_points -> [0], $xy_points -> [1]); # get the first point
2433             if
2434             (
2435             ($xp >= $borders -> [3])
2436             and ($xp <= ($w - $borders -> [1]))
2437             and ($yp >= $borders -> [0])
2438             and ($yp <= ($h - $borders -> [2]))
2439             )
2440             {
2441             # first point is in, put points in the new array
2442             push @p, ($xp, $yp); # push the x, y pair
2443             $last_point = 0; # flag the last point as in
2444             }
2445             for (my $i = 1; $i < $point_count; $i++)
2446             {
2447             ($x, $y) = ($xy_points -> [$i * 2], $xy_points -> [$i * 2 + 1]);
2448             # print "_clip_plot: $i ($x $borders -> [3]) and ($x $w $borders -> [1]) ($y $borders -> [0]) ($y ($h - $borders -> [2])) lastPoint $last_point\n";
2449             if
2450             (
2451             ($x >= $borders -> [3])
2452             and ($x <= ($w - $borders -> [1]))
2453             and ($y >= $borders -> [0])
2454             and ($y <= ($h - $borders -> [2]))
2455             )
2456             {
2457             # OK, this point is in, if the last one was out then we have work to do
2458             if ($last_point == 1) # out
2459             {
2460             $last_point = 0; # in
2461             my ($xn, $yn) = $self -> _clip_line_in_out
2462             (
2463             $x, $y, $xp, $yp,
2464             $borders -> [3], $borders -> [0],
2465             $w - $borders -> [1], $h - $borders -> [2]
2466             );
2467             push (@p, ($xn, $yn));
2468             push (@p, ($x, $y));
2469             ($xp, $yp) = ($x, $y);
2470             }
2471             else # last point was in, this in so we just add a point to the line and carry on
2472             {
2473             push (@p, ($x, $y));
2474             ($xp, $yp) = ($x, $y);
2475             } # end else
2476             }
2477             else # this point out
2478             {
2479             my @args = %args;
2480             if ($last_point == 0) # in
2481             {
2482             # this point is out, last one was in, need to draw a line
2483             my ($x_edge, $y_edge) = $self -> _clip_line_in_out
2484             (
2485             $xp, $yp, $x, $y,
2486             $borders -> [3], $borders -> [0],
2487             $w - $borders -> [1], $h - $borders -> [2]
2488             );
2489             push @p, $x_edge, $y_edge;
2490             $self -> createLine(\@p, %args);
2491             splice(@p, 0); # empty the array?
2492             $last_point = 1; # out
2493             ($xp, $yp) = ($x, $y );
2494             }
2495             else # two points in a row out but maybe the lies goes thru the active area
2496             {
2497             # print "clip two points in a row out of box.\n";
2498             my $p = $self -> _clip_line_out_out
2499             (
2500             $xp, $yp, $x, $y,
2501             $borders -> [3], $borders -> [0],
2502             $w - $borders -> [1], $h - $borders -> [2]
2503             );
2504             $self -> createLine($p, %args)if (@$p >= 4);
2505             $last_point = 1; # out!
2506             ($xp, $yp) = ($x, $y );
2507             } # end else
2508             }
2509             } # end loop
2510             # now when we get out of the loop if there are any points in the @p array, make a line
2511             $self -> createLine(\@p, %args) if (@p >= 4);
2512             return (1);
2513             }
2514              
2515             sub _clip_line_out_out ## no critic (Subroutines::ProhibitManyArgs)
2516             { # x, y , x, y and x, y corners of the box
2517              
2518             # see if the line goes thru the box
2519             # If so, draw the line
2520             # else do nothing
2521             my ($self, $x1, $y1, $x2, $y2, $xb1, $yb1, $xb2, $yb2) = @_;
2522             my (@p, $x, $y);
2523             # print "_clip_line_out_out: ($x1, $y1) , ($x2, $y2), ($xb1, $yb1) , ($xb2, $yb2)\n";
2524             return (\@p) if (($x1 < $xb1) and ($x2 < $xb1)); # line not in the box
2525             return (\@p) if (($x1 > $xb2) and ($x2 > $xb2));
2526             return (\@p) if (($y1 > $yb2) and ($y2 > $yb2));
2527             return (\@p) if (($y1 < $yb1) and ($y2 < $yb1));
2528             # get here the line might pass thru the plot box
2529             # print "_clip_line_out_out: p1($x1, $y1), p2($x2, $y2), box1($xb1, $yb1), box2($xb2, $yb2)\n";
2530             if ($x1 != $x2)
2531             {
2532             my $m = ($y1 - $y2) / ($x1 - $x2); # as in y = mx + c
2533             my $c = $y1 - $m * $x1;
2534             # print "_clip_line_out_out: line m $m c $c\n";
2535             $x = ($m != 0) ? ($yb1 - $c) / $m : $x1; # print "$x $yb1\n";
2536             push @p, ($x, $yb1) if (($x >= $xb1) and ($x <= $xb2));
2537             $x = ($m != 0) ? ($yb2 - $c) / $m : $x1;
2538             push @p, ($x, $yb2) if (($x >= $xb1) and ($x <= $xb2));
2539             $y = $m * $xb1 + $c;
2540             push @p, ($xb1, $y) if (($y >= $yb1) and ($y <= $yb2));
2541             $y = $m * $xb2 + $c;
2542             push @p, ($xb2, $y) if (($y >= $yb1) and ($y <= $yb2));
2543             }
2544             else # Handle vertical lines...
2545             {
2546             $x = $x1; # This is also $x2 of course!
2547             push @p, ($x, $yb1) if (($x >= $xb1) and ($x <= $xb2));
2548             $x = $x1;
2549             push @p, ($x, $yb2) if (($x >= $xb1) and ($x <= $xb2));
2550             }
2551             # print "_clip_line_out_out: @p", "\n";
2552             return (\@p)
2553             }
2554              
2555             sub _clip_line_in_out ## no critic (Subroutines::ProhibitManyArgs)
2556             { # x, y (1 in), x, y (2 out) and x, y corners of the box
2557              
2558             # We have two points, one in the box, one outside of the box
2559             # Find where the line between the two points intersects the edges of the box
2560             # returns that point
2561             # Notebook page 106
2562             my ($self, $x1, $y1, $x2, $y2, $xb1, $yb1, $xb2, $yb2) = @_; ## no critic (Subroutines::ProhibitManyArgs)
2563             # print "_clip_line_in_out: ($x1, $y1) , ($x2, $y2), ($xb1, $yb1) , ($xb2, $yb2)\n";
2564             my ($xi, $yi);
2565             if ($x1 == $x2) # line par to y axis
2566             {
2567             # print "_clip_line_in_out: Line parallel to y axis\n";
2568             $xi = $x1;
2569             $yi = ($y2 < $yb1) ? $yb1 : $yb2;
2570             return ($xi, $yi);
2571             }
2572             if ($y1 == $y2) # line par to x axis
2573             {
2574             # print "_clip_line_in_out: Line parallel to y axis\n";
2575             $yi = $y1;
2576             $xi = ($x2 < $xb1) ? $xb1 : $xb2;
2577             return ($xi, $yi);
2578             }
2579             # y = mx + b; m = dy / dx b = y1 - m * x1 x = (y - b) / m
2580             if (($x1 - $x2) != 0)
2581             {
2582             my $m = ($y1 - $y2) / ($x1 - $x2);
2583             my $c = $y1 - $m * $x1;
2584             if ($y2 <= $y1) # north border
2585             {
2586             $xi = ($yb1 - $c) / $m;
2587             return ($xi, $yb1) if (($xi >= $xb1) and ($xi <= $xb2));
2588             }
2589             else # south border
2590             {
2591             $xi = ($yb2-$c) / $m;
2592             return ($xi, $yb2) if (($xi >= $xb1) and ($xi <= $xb2));
2593             }
2594             if ($x2 <= $x1) # west border
2595             {
2596             $yi = $m * $xb1 + $c;
2597             return ($xb1, $yi) if (($yi >= $yb1) and ($yi <= $yb2));
2598             }
2599             # only one remaining is east border
2600             $yi = $m * $xb2 + $c;
2601             return ($xb2, $yi) if (($yi >= $yb1) and ($yi <= $yb2));
2602             }
2603             else # dx == 0, vertical line, north or south border
2604             {
2605             return ($x1, $yb1) if ($y2 <= $yb1);
2606             return ($x1, $yb2) if ($y2 >= $yb2);
2607             }
2608             warn '_clip_line_in_out() reach this point in the code';
2609             return (0, 0);
2610             }
2611              
2612             # There are three coordinate systems in use.
2613             # 1. World - Units are the physical system being plotted. Amps, DJ Average, dollars, etc
2614             # 2. Plot - Units are pixels. The (0, 0) point is the lower left corner of the canvas
2615             # 3. Canvas - Units are pixels. The (0, 0) point is the upper left corner of the canvas.
2616              
2617             sub _to_world_points # x, y in the Canvas system
2618             {
2619             # convert to World points
2620             # get points on canvas from system in pixels, need to change them into units in the plot
2621             my ($self, $xp, $yp) = @_;
2622             my $borders = $self -> cget(-border); # north, east, south, west
2623             my $s = $self -> cget(-scale); # min X, max X, interval, min y, max y,
2624             my $h = $self -> height;
2625             my $w = $self -> width;
2626             my $x = ($xp - $borders -> [3]) * ($s -> [1] - $s -> [0])
2627             / ($w - $borders -> [1] - $borders -> [3]) + $s -> [0];
2628             my $y = (($h-$yp) - $borders -> [2]) * ($s -> [4] - $s -> [3])
2629             / ($h - $borders -> [0] - $borders -> [2]) + $s -> [3];
2630             # but if the axes are log some more work to do.
2631             my $y1 = (($h - $yp) - $borders -> [2]) * ($s -> [7] - $s -> [6])
2632             / ($h - $borders -> [0] - $borders -> [2]) + $s -> [6];
2633             $x = 10 ** $x if ($self -> cget('-xType') eq 'log');
2634             $y = 10 ** $y if ($self -> cget('-yType') eq 'log');
2635             $y1 = 10 ** $y1 if ($self -> cget('-y1Type') eq 'log');
2636             # print "_to_world_points: ($xp, $yp) to ($x, $y, $y1)\n";
2637             return ($x, $y, $y1);
2638             }
2639              
2640             sub _to_canvas_pixels # which, x, y
2641             {
2642             # given an x, y value in axis or canvas system return x, y in Canvas pixels.
2643             # axis => x, y are pixels relative to where the border is
2644             # canvas => x, y are pixels in the canvas system.
2645             # more to follow ?
2646             my ($self, $which, $x, $y) = @_;
2647             my ($x_out, $y_out);
2648             if ($which eq 'axis')
2649             {
2650             my $borders = $self -> cget(-border);
2651             return ($x + $borders -> [3], $self -> height - ($y + $borders -> [2]));
2652             }
2653             if ($which eq 'canvas')
2654             {
2655             return ($x, $self -> height - $y);
2656             }
2657             } # end _to_canvas_pixels
2658              
2659             sub _arrays_to_canvas_pixels # which, x array ref, y array ref also errors
2660             {
2661             # given x array ref and y aray ref generate the one array, xy in canvas pixels
2662             my ($self, $which, $xa, $ya, $dyap, $dyam) = @_;
2663             my (@xy_out, @dyp_out, @dym_out);
2664             my $h = $self -> height;
2665             my $borders = $self -> cget(-border);
2666             if ($which eq 'axis')
2667             {
2668             for (my $i = 0; $i < @$ya; $i++)
2669             {
2670             $xy_out[$i * 4] = $xa -> [$i] + $borders -> [3];
2671             $xy_out[$i * 4 + 1] = $h - ($ya -> [$i] + $borders -> [2]);
2672             $xy_out[$i * 4 + 2] = $h - ($dyap -> [$i] + $borders -> [2]);
2673             $xy_out[$i * 4 + 3] = $h - ($dyam -> [$i] + $borders -> [2]);
2674             }
2675             return (@xy_out);
2676             }
2677             }
2678              
2679             sub _ds_to_plot_pixels # ref to xArray and yArray with ds values, which y axis
2680             {
2681             # ds is dataSet. They are in world system
2682             # convert to Plot pixels, return ref to converted x array and y array
2683             # if y-errors are given, also convert these and return two more arrays
2684             # - ypluserror, yminuserror
2685             # if no y-errors are given, set them virtually to zero and return the arrays as well
2686              
2687             my ($self, $xa, $ya, $dya, $y_axis) = @_;
2688             my $s = $self -> cget(-scale);
2689             my ($x_min, $x_max, $y_min, $y_max);
2690             ($x_min, $x_max, $y_min, $y_max) = ($s -> [0], $s -> [1], $s -> [3], $s -> [4]);
2691             ($x_min, $x_max, $y_min, $y_max) = ($s -> [0], $s -> [1], $s -> [6], $s -> [7]) if ($y_axis eq 'Y1');
2692             # print "_ds_to_plot_pixels: X($x_min, $x_max), Y($y_min, $y_max)\n";
2693             my $borders = $self -> cget(-border);
2694             my ($nb, $eb, $sb, $wb) = ($borders -> [0], $borders -> [1], $borders -> [2], $borders -> [3]);
2695             my $h = $self -> height;
2696             my $w = $self -> width;
2697             my (@xR, @yR, @dypR, @dymR); # converted values to be returned (including errors)
2698             my $sfX = ($w-$eb-$wb) / ($x_max - $x_min);
2699             my $sfY = ($h-$nb-$sb) / ($y_max - $y_min);
2700             my ($x, $y);
2701             for (my $i = 0; $i < @{$xa}; $i++)
2702             {
2703             push @xR, ($xa -> [$i] - $x_min) * $sfX if (defined($xa -> [$i]));
2704             push @yR, ($ya -> [$i] - $y_min) * $sfY if (defined($ya -> [$i]));
2705              
2706             # if y-Errors are given, also convert to pixels
2707             if ($dya -> [0])
2708             {
2709             push @dypR, ($dya -> [0] -> [$i] - $y_min) * $sfY; # errors are absolute vals from here...
2710             push @dymR, ($dya -> [1] -> [$i] - $y_min) * $sfY;
2711             }
2712             else
2713             {
2714             push @dypR, ($ya -> [$i] - $y_min) * $sfY; # if no errors are given, set them to zero
2715             push @dymR, ($ya -> [$i] - $y_min) * $sfY;
2716             }
2717             }
2718             return (\@xR, \@yR, \@dypR, \@dymR);
2719             }
2720              
2721             sub _nice_range # input is min, max,
2722             {
2723             # return is a new min, max and an interval for the tick marks
2724             # interval is not the number of intervals but the size of the interval
2725             # find a good min, max and interval for the axis
2726             # if min > max return min 0, max 100, interval of 10.
2727             my ($min, $max) = @_;
2728             my $delta = $max - $min;
2729             return (0, 100, 10) if ($delta < 0); # AC: Set standard scale for negative ranges
2730             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!)
2731             my $r = ($max != 0) ? $delta/$max : $delta;
2732             $r = -$delta / $min if ($max < 0);
2733             my $spaces = 10; # number
2734             # don't want a lot of ticks if the size of the space is very small compaired to values
2735             $spaces = 2 if ($r < 1e-2);
2736              
2737             while (1) # do this until a return
2738             {
2739             # print "ratio <$r> \n";
2740             # $spaces = 2 if ($r < 1e-08);
2741             my $interval = $delta / $spaces;
2742             my $power = floor(log10($delta));
2743             # print "min, max $min, $max delta $delta power $power interval $interval $spaces\n";
2744             # find a good interval for the ticks
2745             $interval = $interval * (10 ** -$power) * 10;
2746             # print "min, max $min, $max delta $delta power $power interval $interval\n";
2747             # now round this up the next whole number but not 3 or 6, 7 or 9.
2748             # leaves 1, 2, 4, 5, 8
2749             $interval = ceil($interval);
2750             $interval = 8 if (($interval == 7) or ($interval == 6));
2751             $interval = 10 if ($interval == 9);
2752             $interval = 4 if ($interval == 3);
2753             #print "min, max $min, $max delta $delta power $power interval $interval\n";
2754             $interval = $interval * (10 ** (+$power - 1));
2755             #print "min, max $min, $max delta $delta power $power interval $interval\n";
2756             # find the new min
2757             my ($new_max, $new_min);
2758             my $new_delta = $interval * $spaces;
2759             if ($new_delta == $delta)
2760             {
2761             $new_max = $max;
2762             $new_min = $min;
2763             }
2764             else
2765             {
2766             my $n = $min / $interval;
2767             my $n_floor = floor($n);
2768             # print "n $n floor of n is $n_floor \n";
2769             $new_min = $n_floor * $interval;
2770             $new_max = $new_min + $new_delta;
2771             if ($new_max <= $max)
2772             {
2773             # Add an extra space to include data missed off by reducing the minimum value
2774             $new_delta += $interval;
2775             $spaces++;
2776             $new_max = $new_min + $new_delta;
2777             }
2778             }
2779             # print "_nice_range: min, max $min, $max delta $delta power $power interval $interval newMin $new_min newMax $new_max \n";
2780              
2781             # now see how much of the space has been used. If there is a lot empty, increase the number of spaces (ticks)
2782             return ($new_min, $new_max, $interval) if ($spaces <= 3);
2783             return ($new_min, $new_max, $interval) if ((($new_delta / $delta) < 1.4) and ($new_max >= $max));
2784             $spaces++;
2785             }
2786              
2787             die '_nice_range() should not reach this point in the code';
2788             }
2789              
2790             sub _log_range # min, max
2791             {
2792             # for scaling a log axis
2793             #returns a max and min, intervals and an array ref that contains labels for the ticks
2794             # Optional args -tickFormat
2795             # The sprintf format to use. If not specified, then '1e%3.2d' will be used
2796             # for values less than zero and '1e+%2.2d' will be used for values of zero
2797             # or more.
2798             my ($self, $min, $max, %args) = @_;
2799             my $tick_format = delete $args{-tickFormat};
2800              
2801             unless (defined($min) and defined($max))
2802             {
2803             $min = 0.1;
2804             $max = 1000;
2805             }
2806              
2807             if ($min <= 0)
2808             {
2809             my $t = $self -> cget(-logMin);
2810             # print "Can't log plot data that contains numbers less than or equal to zero.\n";
2811             # print "Data min is: <$min>. Changed to $t\n";
2812             $min = $self -> cget(-logMin);
2813             # set a flag to indicate the log data must be checked for min!
2814             $self -> {-logCheck} = 1; # true
2815             }
2816             my $delta = $max - $min;
2817             my $first;
2818             my @t_label;
2819              
2820             my $max_p = ceil(log10($max));
2821             $max_p = $max_p + 1 if ($max_p < 0);
2822             my $min_p = floor(log10($min));
2823             my $f;
2824             # print "_log_range: max $max, min $min, $max_p, $min_p)\n";
2825             foreach my $t ($min_p..$max_p)
2826             {
2827             my $n = 10.0 ** $t;
2828             # print "_log_range: <$n> <$t>\n";
2829             if ($tick_format)
2830             {
2831             $f = sprintf($tick_format, $t);
2832             }
2833             elsif ($t < 0)
2834             {
2835             $f = sprintf('1e%3.2d', $t);
2836             }
2837             else
2838             {
2839             $f = sprintf('1e+%2.2d', $t);
2840             }
2841             # print "_log_range: $f \n";
2842             push @t_label, $f;
2843             }
2844             return ($min_p, $max_p, 1, \@t_label);
2845             # look returning min Power and the max Power. Note the power step is always 1 this might not be good
2846             # used 1e-10, 1e-11 and so on. Looks good to me!
2847             }
2848              
2849             1;
2850