| 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
|
|
|
|
|
|
|
|