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