File Coverage

blib/lib/Text/LookUpTable.pm
Criterion Covered Total %
statement 220 321 68.5
branch 38 62 61.2
condition 4 15 26.6
subroutine 22 26 84.6
pod 9 17 52.9
total 293 441 66.4


line stmt bran cond sub pod time code
1             package Text::LookUpTable;
2              
3 1     1   2005 use strict;
  1         4  
  1         48  
4 1     1   7 use warnings;
  1         1  
  1         33  
5 1     1   22 use Carp;
  1         3  
  1         82  
6              
7 1     1   5 use vars qw($VERSION);
  1         2  
  1         80  
8              
9             $VERSION = 0.05;
10 1     1   20 use 5.6.1;
  1         4  
  1         75  
11              
12 1     1   5 use overload q("") => \&as_string;
  1         2  
  1         12  
13              
14 1     1   2575 use Text::Aligner qw(align);
  1         13174  
  1         68  
15 1     1   1285 use File::Slurp qw(read_file);
  1         15056  
  1         3561  
16              
17             =head1 NAME
18              
19             Text::LookUpTable - Perl5 module for text based look up table operations
20              
21             =head1 SYNOPSIS
22              
23             $tbl = Text::LookUpTable->load_file('my_table.tbl');
24             $tbl = Text::LookUpTable->load($str_tbl);
25             $tbl = Text::LookUpTable->load_blank($x_size, $y_size, $x_title, $y_title);
26              
27             print $tbl;
28             $str_tbl = "$tbl";
29              
30             $tbl->save_file();
31             $tbl->save_file('my_table.tbl');
32              
33             $tbl->set($x, $y, $val);
34              
35             @diff_coords = $tbl->diff($tbl2);
36             $diffp = $tbl->diff($tbl2, 1); # true/false no coordinates
37              
38             @xdiffs = $tb1->diff_x_coords($tb2);
39             @ydiffs = $tb1->diff_y_coords($tb2);
40              
41             @x_coords = $tbl->get_x_coords();
42             @y_coords = $tbl->get_y_coords();
43              
44             $res = $tbl->set_x_coords(@x_coords);
45             $res = $tbl->set_y_coords(@y_coords);
46              
47             @ys = $tbl->get_y_vals($x_offset);
48             @xs = $tbl->get_x_vals($y_offset);
49              
50             $str_plot = $tbl->as_plot('R');
51             print FILE $str_plot;
52              
53             =head1 DESCRIPTION
54              
55             Text::LookUpTable provides operations for creating, storing, displaying,
56             plotting, loading, and querying a I structure. The format
57             of the stored structure is designed to be visually easy to understand
58             so that it can be easily edited using a text editor.
59              
60             The authors inteded use of this library is to allow a user to edit a
61             text file representation of a look up table which can then be loaded
62             in to an embedded controller such as MegaSquirt [http://www.msextra.com].
63             Additional code would be needed to convert this generic structure
64             to whatever application specific format is required.
65              
66             What is a I and how is it different than a I?
67             A I is commonly used in embedded controllers to avoid the
68             use of costly floating pointing operations by looking up a value based
69             on the input coordiantes. A function with two inputs (f(x, y)) which
70             would use floating point operations can be represented (with some loss
71             in precsion) as a table.
72              
73             In contrast a I (or spreadsheet) has any number of columns/rows.
74             The columns can be of different types. And a table does not try to represent
75             any sort of function, it just stores data.
76              
77             =head1 STRING FORMAT
78              
79             The format of the look up table when stored to a string or file should
80             look like the example below.
81              
82             rpm
83            
84             [1000] [1500] [2000] [2500]
85             [100] 14.0 15.5 16.4 17.9
86             map [90] 13.0 14.5 15.3 16.8
87             [80] 12.0 13.5 14.2 15.7
88              
89             The x (across top) and y (left column) coordinates have there values
90             enclosed in square brackets. All values must be present.
91             And the titles can only span one line. There can be any number of
92             lines and spaces as long as the values can be discerned.
93             When saving and restoring a table the original spacing will not be
94             preserved.
95              
96             The x values start at offset 0 at the left and increase towards the right.
97             The y values start at offset 0 at the bottom and increase upward.
98              
99             =head1 OPERATIONS
100              
101             =cut
102              
103             #
104             # DEVNOTE:
105             # The position offset calculations are quite tedious.
106             # It is recommended to use only the high level functions already defined
107             # to access these values and to not access the structure in the object directly.
108             #
109              
110             # {{{ load
111              
112             =head2 Text::LookUpTable->load($string);
113              
114             Returns: a new table object on success, FALSE on error
115              
116             Creates a new look up table object by parsing the given string.
117             See the section I for details on format it expects.
118              
119             If you want to load a table from a I see I.
120              
121             =cut
122              
123             sub load {
124 15     15 1 8170 my $class = shift;
125 15         26 my $str_tbl = shift;
126              
127              
128             # An example of a displayed look up table.
129             #
130             # rpm
131             #
132             # [1000] [1500] [2000] [2500]
133             # [100] 14.0 15.5 16.4 17.9
134             # map [90] 13.0 14.5 15.3 16.8
135             # [80] 12.0 13.5 14.2 15.7
136             #
137             #
138             #
139             # The text is split on spaces and based on the number of spaces
140             # it is determined which data is which.
141             #
142             # The x title should have 1 value with spaces on either side.
143             #
144             # The x coordinates should have num_x values in square brackets []
145             #
146             # A regular row should have num_x values + 1 coordinates in square brackets.
147             #
148             # The row with the y title should have num_x values + 2
149             #
150              
151 15         102 my @lines = split /\n/, $str_tbl;
152              
153 15         33 my $x_title;
154             my $y_title;
155 0         0 my @x_coords;
156 0         0 my @y_coords;
157 0         0 my $num_x_coords;
158 15         24 my $num_y_coords = 0;
159 15         16 my @vals;
160              
161 15         63 for (my $i = 0; $i < @lines; $i++) {
162 111         170 my $line = $lines[$i];
163 111         406 my @raw_parts = split /[\s]+/, $line;
164              
165             # split saves some entries even though they are blank.
166             # Particularly the title has two values and one is blank.
167             # Remove these blank entries.
168 111         134 my @parts;
169 111         152 foreach my $part (@raw_parts) {
170 373 100       1146 if ($part =~ /\w/) {
171 291         507 push @parts, $part;
172             }
173             }
174              
175 111         161 my $num_parts = @parts;
176              
177             #print "num_parts: $num_parts\n"; # DEBUG
178              
179             # skip blank lines
180 111 100       412 next if (0 == $num_parts);
181              
182 82 100       151 if (1 == $num_parts) {
183              
184 16 100       39 if (defined $x_title) {
185 1         201 carp "ERROR: Multi line x titles are not supported, error on line " . ($i + 1) . "";
186 1         7 return;
187             }
188              
189 15         21 $x_title = $parts[0];
190             #print "x_title: '$x_title'\n"; # DEBUG
191              
192 15         56 next;
193             }
194              
195             # x coordinates line across top with values in square brackets
196 66 100       137 if (! defined $num_x_coords) {
197 14         19 $num_x_coords = $num_parts;
198              
199 14         22 foreach my $part (@parts) {
200 46         112 $part =~ s/\[//;
201 46         98 $part =~ s/\]//;
202              
203 46         84 push @x_coords, $part;
204             }
205             #print "x_coord[1]: " . $x_coords[3] . "\n"; # DEBUG
206              
207 14         69 next;
208             }
209              
210             # y title, 1 y coordinate, and data
211             # Take the title, remove it from @parts and let
212             # the data be processed in the next step
213 52 100       110 if (($num_x_coords + 2) == $num_parts) {
214              
215 14 100       29 if (defined $y_title) {
216 1         202 carp "ERROR: Multi line y titles are not supported, error on line " . ($i + 1) . "";
217 1         9 return;
218             }
219              
220 13         19 $y_title = $parts[0];
221             #print "y_title: $y_title\n"; # DEBUG
222              
223 13         22 shift @parts; # remove the title
224 13         19 $num_parts--;
225             }
226              
227             # a normal row
228 51 100       113 if (($num_x_coords + 1) == $num_parts) {
229 49         58 $num_y_coords++;
230              
231 49         68 my $part = shift @parts;
232 49         136 $part =~ s/\[//;
233 49         96 $part =~ s/\]//;
234              
235 49         84 push @y_coords, $part;
236              
237 49         133 push @vals, [@parts];
238              
239 49         196 next;
240             }
241              
242             # If we got here something is wrong!
243 2         3 my $line_num = $i + 1;
244 2         692 carp "ERROR: The data on line " . ($i + 1) . " or before is irregular";
245 2         17 return;
246             }
247              
248 11         113 bless {
249             x_title => $x_title,
250             y_title => $y_title,
251             x => \@x_coords,
252             y => \@y_coords,
253             vals => \@vals,
254             }, $class;
255             }
256             # }}}
257              
258             # {{{ load_file
259              
260             =head2 Text::LookUpTable->load_file($file)
261              
262             Returns: new object on success, FALSE on error
263              
264             Works like I but obtains the text from the $file first.
265              
266             Stores the name of file so that save_file can be used without
267             having to specify the file again.
268              
269             =cut
270              
271             sub load_file {
272 0     0 1 0 my $class = shift;
273 0         0 my $file = shift;
274              
275 0 0       0 unless (-e $file) {
276 0         0 carp "ERROR: File '$file' does not exist.";
277 0         0 return;
278             }
279              
280 0         0 my $str_tbl = read_file($file); # File::Slurp
281              
282 0         0 my $new_tbl = Text::LookUpTable->load($str_tbl);
283              
284 0         0 $new_tbl->{file} = $file;
285              
286 0         0 return $new_tbl;
287             }
288             # }}}
289              
290             # {{{ load_blank
291              
292             =head2 Text::LookUpTable->load_blank($x_size, $y_size, $x_title, $y_title)
293              
294             Returns: new object on success, FALSE on error
295              
296             Creates a blank object with all values initialized to zero and
297             dimensions of $x_size and $y_size.
298              
299             =cut
300              
301             sub load_blank {
302 2     2 1 959 my $class = shift;
303 2         3 my $x_size = shift;
304 2         4 my $y_size = shift;
305 2         29 my $x_title = shift;
306 2         3 my $y_title = shift;
307              
308 2 50 33     20 unless (defined $x_size and $x_size > 0) {
309 0         0 carp "ERROR: x_size must be a value > 0, '$x_size' invalid.";
310 0         0 return;
311             }
312              
313 2 50 33     14 unless (defined $y_size and $y_size > 0) {
314 0         0 carp "ERROR: y_size must be a value > 0, '$y_size' invalid.";
315 0         0 return;
316             }
317              
318 2 50 33     14 unless (defined $x_title and $x_title ne '') {
319 0         0 carp "ERROR: x_title must be a non-empty string, '$x_title'.";
320 0         0 return;
321             }
322              
323 2 50 33     12 unless (defined $y_title and $y_title ne '') {
324 0         0 carp "ERROR: y_title must be a non-empty string, '$y_title'.";
325 0         0 return;
326             }
327              
328 2         4 my @xs;
329 2         7 for (my $i = 0; $i < $x_size; $i++) {
330 4         21 $xs[$i] = 0;
331             }
332              
333 2         2 my @ys;
334 2         13 for (my $i = 0; $i < $y_size; $i++) {
335 8         19 $ys[$i] = 0;
336             }
337              
338 2         3 my @vals;
339 2         46 for (my $i = 0; $i < $y_size; $i++) {
340 8         26 push @vals, [@xs];
341             }
342              
343 2         19 bless {
344             x_title => $x_title,
345             y_title => $y_title,
346             x => \@xs,
347             y => \@ys,
348             vals => \@vals,
349             }, $class;
350             }
351             # }}}
352              
353             # {{{ as_string
354              
355             =head2 $tbl->as_string();
356              
357             Returns string on success, FALSE on error.
358              
359             Convert the object to a string representation.
360              
361             This operation is used to overload the string operation so
362             the shorthand form can be used.
363              
364             print $tbl; # print the object as a string
365              
366             $to_save = "$tbl"; # get the string format to be saved
367              
368             The long hand form $tbl->as_string(); should not normally be needed.
369              
370             =cut
371              
372              
373             # An example of a displayed look up table.
374             #
375             # rpm
376             #
377             # [12] [15] [17] [35] (x coordinates title)
378             # [100] 3 15 4 2
379             # map [120] 10 12 3 4
380             # [130] 15.2 12 13 20
381             #
382              
383              
384             sub as_string {
385 24     24 1 1876 my $self = shift;
386              
387 24         33 my $SPACE = ' ';
388 24         28 my $num_y = @{$self->{y}};
  24         50  
389 24         51 my $num_x = @{$self->{x}};
  24         37  
390              
391             # Once it is know how many rows will be displayed
392             # it can be determined which row to place the y_title on.
393             #
394             # The first 3 lines are for the title, so ignore those for
395             # these calculations.
396             #
397             # $c is the line from offset 0, to place the y title on.
398 24         55 my $c = int($num_y / 2);
399              
400 24         33 my $num_rows = $num_y + 1; # add 1 for x coordinates
401              
402             # y title column
403 24         30 my @yt_column;
404 24         72 for (my $i = 0; $i < $num_rows; $i++) {
405 120 100       376 $yt_column[$i] = ($i == $c) ? " " . $self->{y_title} : " ";
406             }
407 24         79 @yt_column = align('left', @yt_column);
408              
409             # y coordinates column
410 24         18127 my @y_column;
411 24         44 $y_column[0] = " ";
412 24         79 for (my $i = 1; $i < $num_rows; $i++) {
413 96         325 $y_column[$i] = " [" . $self->{y}[$i - 1] . "] ";
414             }
415 24         74 @y_column = align('left', @y_column);
416              
417             # x coordinate and values column
418 24         16773 my @val_cols;
419 24         76 for (my $i = 0; $i < $num_x; $i++) {
420             # XXX
421 72         260 my @vals = ("[" . $self->{x}[$i] . "]", (reverse $self->get_y_vals($i)));
422              
423 72         319 my @col = align('left', @vals);
424              
425 72         40238 push @val_cols, \@col;
426             }
427              
428 24         35 my @lines;
429 24         83 for (my $i = 0; $i < $num_y + 1; $i++) {
430             # first the y title and y coordinate values
431 120         206 my $line = $yt_column[$i] . $SPACE . $y_column[$i];
432              
433             # then the rest of the values
434 120         251 for (my $j = 0; $j < $num_x; $j++) {
435 360         855 $line .= $SPACE . $val_cols[$j][$i];
436             }
437              
438 120         314 push @lines, $line;
439             }
440              
441              
442             # The x title is treated separately without using align().
443             # All the rest is formatted with align().
444 24         46 my $x_title = $self->{x_title};
445 24         29 my $len = length $lines[0];
446 24         29 my $len_t = length $x_title;
447 24 50       51 if ($len_t > $len) {
448 0         0 warn "x title is too big!";
449 0         0 return undef;
450             }
451 24         33 my $gap = $len - $len_t;
452 24         50 my $gap_one = int($gap / 2);
453 24         45 my $fill = " " x $gap_one;
454              
455 24         44 my $str = "\n" . $fill . $x_title . "\n\n";
456              
457 24         86 $str .= join "\n", @lines;
458              
459 24         34 $str .= "\n";
460              
461 24         258 return $str;
462             }
463              
464             # }}}
465              
466             # {{{ save
467              
468             =head2 $tbl->save_file($file);
469              
470             Returns TRUE on success, FALSE on error
471              
472             Optional argument $file, can specify the file to save to.
473             If ommitted it will save to the last file that was used.
474             If no last file is stored it will produce an error.
475              
476             =cut
477              
478             sub save_file {
479 0     0 1 0 my $self = shift;
480 0         0 my $file = shift;
481              
482 0 0 0     0 if (! defined $file or $file =~ /^[\s]+$/) {
483 0         0 carp "ERROR: trying to save but no file specified and no file stored.";
484 0         0 return;
485             }
486              
487 0         0 $self->{file} = $file;
488              
489 0         0 my $res = open FILE, "> $file";
490 0 0       0 if (! $res) {
491 0         0 carp "ERROR: unable to open file '$file': $!";
492 0         0 return;
493             }
494              
495 0         0 print FILE $self;
496              
497 0         0 close FILE;
498              
499 0         0 return 1; # success
500             }
501              
502             # }}}
503              
504             # {{{ get_*_coords
505              
506             =head2 $tbl->get_*_coords();
507              
508             Returns list of all x/y coordinates on success, FALSE on error
509              
510             Offset 0 for the X coordinates start at the LEFT of the displayed table
511             and increases RIGHTWARD.
512              
513             Offset 0 for the Y coordinates start at the TOP of the displayed table
514             and increases DOWNWARD.
515              
516             @xs = $tbl->get_x_coords();
517             @ys = $tbl->get_y_coords();
518              
519             =cut
520              
521             sub get_x_coords {
522 9     9 0 19 my $self = shift;
523              
524 9         15 @{$self->{x}};
  9         34  
525             }
526              
527             sub get_y_coords {
528 9     9 0 488 my $self = shift;
529              
530 9         13 @{$self->{y}};
  9         38  
531             }
532             # }}}
533              
534             # {{{ set_*_coords
535              
536             =head2 $tbl->set_*_coords(@new_coords);
537              
538             Returns TRUE on success, FALSE on error
539              
540             Assigns the x/y coordinates to the values given in the list.
541              
542             $res = $tbl->set_x_coords(@new_x_coords);
543             $res = $tbl->set_y_coords(@new_y_coords);
544              
545             =cut
546              
547             sub set_x_coords {
548 1     1 0 5 my $self = shift;
549 1         3 my @vals = @_;
550              
551 1         2 my $num_x_coords = @{$self->{x}};
  1         3  
552 1         2 my $num_new_x_coords = @vals;
553              
554 1 50       5 if ($num_x_coords != $num_new_x_coords) {
555 0         0 carp "ERROR: The number of x coordinates must be the same ($num_x_coords != $num_new_x_coords)";
556 0         0 return;
557             }
558              
559 1         4 $self->{x} = [@vals];
560              
561 1         3 return 1;
562             }
563              
564             sub set_y_coords {
565 1     1 0 497 my $self = shift;
566 1         4 my @vals = @_;
567              
568 1         2 my $num_y_coords = @{$self->{y}};
  1         3  
569 1         3 my $num_new_y_coords = @vals;
570              
571 1 50       4 if ($num_y_coords != $num_new_y_coords) {
572 0         0 carp "ERROR: The number of y coordinates must be the same ($num_y_coords != $num_new_y_coords)";
573 0         0 return;
574             }
575              
576 1         4 $self->{y} = [@vals];
577              
578 1         5 return 1;
579             }
580             # }}}
581              
582             # {{{ get_*_vals
583              
584             =head2 $tbl->get_*_vals($offset);
585              
586             Returns list of values on success OR FALSE on error
587              
588             Retrives all values for a given offset.
589              
590             @xs = get_x_vals($y_offset);
591             @ys = get_y_vals($x_offset);
592              
593             The 0 offset of the returned list will correspond to the 0 offset of the displayed
594             table.
595              
596             =cut
597              
598             sub get_y_vals {
599 103     103 0 1738 my $self = shift;
600 103         116 my $x = shift;
601              
602 103         103 my $num_x = @{$self->{x}};
  103         195  
603 103         111 my $num_y = @{$self->{y}};
  103         157  
604              
605 103 50       212 unless ($x < $num_x) {
606 0         0 carp "ERROR: there is no y value at position $x";
607 0         0 return;
608             }
609              
610 103         11589 my @res_vals;
611 103         154 my $vals = $self->{vals};
612 103         232 for (my $i = 0; $i < $num_y; $i++) {
613 412         460 my $xs = $vals->[$i];
614              
615 412         1272 unshift @res_vals, $xs->[$x];
616             # The bottom y value in the displayed table is at offset zero
617             # this is why unshift is used instead of push.
618             }
619              
620 103         465 return @res_vals;
621             }
622              
623             sub get_x_vals {
624 2     2 0 579 my $self = shift;
625 2         3 my $y = shift;
626              
627 2         5 my $num_x = @{$self->{x}};
  2         6  
628              
629 2 50       9 unless ($y < $num_x) {
630 0         0 carp "ERROR: y offset $y is out of bounds";
631 0         0 return;
632             }
633              
634 2         4 my $vals = $self->{vals};
635              
636 2         2 return (@{$self->{vals}[$y]});
  2         11  
637             }
638              
639             # }}}
640              
641             # {{{ set
642              
643             =head2 $tbl->set($x, $y, $val);
644              
645             Returns TRUE on success OR FALSE on error
646              
647             Set the value to $val at the given $x and $y coordinate offset.
648              
649             =cut
650              
651             sub set {
652 2     2 1 786 my $self = shift;
653 2         4 my $x = shift;
654 2         3 my $y = shift;
655 2         4 my $val = shift;
656              
657 2         4 my $num_x = @{$self->{x}};
  2         23  
658 2         3 my $num_y = @{$self->{y}};
  2         4  
659              
660 2 50       7 unless ($y < $num_y) {
661 0         0 carp "ERROR: A y offset of $y is beyond the boundary ".($num_y - 1)."";
662 0         0 return;
663             }
664              
665 2 50       6 unless ($x < $num_x) {
666 0         0 carp "ERROR: A x offset of $x is beyond the boundary ".($num_x - 1)."";
667 0         0 return;
668             }
669              
670 2         6 $self->{vals}[($num_y - 1) - $y][$x] = $val;
671             # See get() for an explanation of the $y calculation
672              
673 2         5 return 1; # success
674             }
675             # }}}
676              
677             # {{{ get
678              
679             =head2 $tbl->get($x, $y);
680              
681             Returns $value on success, FALSE on error
682              
683             Get the value at the given $x and $y coordinate offset.
684              
685             =cut
686              
687             sub get {
688 0     0 1 0 my $self = shift;
689 0         0 my $x = shift;
690 0         0 my $y = shift;
691              
692 0         0 my $num_x = @{$self->{x}};
  0         0  
693 0         0 my $num_y = @{$self->{y}};
  0         0  
694              
695 0 0       0 unless ($y < $num_y) {
696 0         0 carp "ERROR: A y offset of $y is beyond the boundary ".($num_y - 1)."";
697 0         0 return;
698             }
699              
700 0 0       0 unless ($x < $num_x) {
701 0         0 carp "ERROR: A x offset of $x is beyond the boundary ".($num_x - 1)."";
702 0         0 return;
703             }
704              
705             #
706             # The y offset starts at 0 at the bottom, not the top so it must be adjusted.
707             # (length(@ys) - 1) - y
708             #
709             # 0 -> 4
710             # 1 -> 3
711             # 2 -> 2
712             # 3 -> 1
713             # 4 -> 0
714             #
715 0         0 $self->{vals}[($num_y - 1) - $y][$x];
716             }
717             # }}}
718              
719             # {{{ diff
720              
721             =head2 $tb1->diff($tb2, $break);
722              
723             Returns TRUE if different, FALSE otherwise.
724              
725             If $break is FALSE it returns a list of positions that are different.
726              
727             Determines whether the VALUES two tables are different.
728             Does not check if the coordinates or the titles are different.
729              
730             If $brake is FALSE return a complete list of coordinates that are different.
731             If $brake is TRUE it breaks out and returns as soon it is found that they are
732             different for a slight performance improvement.
733              
734             =cut
735              
736             sub diff {
737 5     5 1 19 my $tbl1 = shift;
738 5         6 my $tbl2 = shift;
739 5         8 my $break = shift;
740              
741 5         13 my $num_x = ($tbl1->get_x_coords());
742 5         14 my $num_y = ($tbl1->get_y_coords());
743              
744 5         9 my @diff_points;
745 5         15 for (my $i = 0; $i < $num_x; $i++) {
746 15         32 my @ys1 = $tbl1->get_y_vals($i);
747 15         39 my @ys2 = $tbl2->get_y_vals($i);
748              
749 15         39 for (my $j = 0; $j < $num_y; $j++) {
750 57 100       213 if ($ys1[$j] != $ys2[$j]) {
751 3         7 push @diff_points, [$i, $j];
752              
753 3 100       42 return 1 if ($break);
754             }
755             }
756             }
757              
758 4 100       11 if (@diff_points) {
759 2         11 return @diff_points;
760             } else {
761 2         9 return 0;
762             }
763             }
764             # }}}
765              
766             # {{{ diff_*_coords
767              
768             =head2 $tb1->diff_*_coords($tb2)
769              
770             Returns list of differences on success, FALSE on error
771              
772             @xdiffs = $tb1->diff_x_coords($tb2);
773             @ydiffs = $tb1->diff_y_coords($tb2);
774              
775             =cut
776              
777             sub diff_x_coords {
778 1     1 0 517 my $tbl1 = shift;
779 1         4 my $tbl2 = shift;
780              
781 1         4 my @coords1 = $tbl1->get_x_coords();
782 1         4 my @coords2 = $tbl2->get_x_coords();
783              
784 1         6 _diff_coords(\@coords1, \@coords2);
785             }
786              
787             sub diff_y_coords {
788 1     1 0 1079 my $tbl1 = shift;
789 1         4 my $tbl2 = shift;
790              
791 1         5 my @cs1 = $tbl1->get_y_coords();
792 1         6 my @cs2 = $tbl2->get_y_coords();
793              
794 1         4 _diff_coords(\@cs1, \@cs2);
795             }
796              
797             sub _diff_coords {
798 2     2   4 my $cs1 = shift;
799 2         3 my $cs2 = shift;
800              
801 2         3 my $num_cs1 = @$cs1;
802 2         4 my $num_cs2 = @$cs2;
803              
804 2 50       7 if ($num_cs1 != $num_cs2) {
805 0         0 carp "ERROR: cant compare tables with different geometries";
806 0         0 return;
807             }
808              
809 2         3 my @diffs;
810 2         8 for (my $i = 0; $i < $num_cs1; $i++) {
811 7 100       31 if ($cs1->[$i] != $cs2->[$i]) {
812 2         7 push @diffs, $i;
813             }
814             }
815              
816 2         9 return @diffs;
817             }
818              
819             # }}}
820              
821             # {{{ as_plot
822              
823             =head2 $tbl->as_plot('plot type', [type specific args ...] );
824              
825             Returns TRUE on success, FALSE on error.
826              
827             Convert the table to a representation suitable for plotting.
828             The string may need to be output to a file depending on how the
829             plotting program is called.
830              
831             See below for the various plot types.
832              
833             =head3 R [www.r-project.org]
834              
835             Returns: string on success, FALSE on error
836              
837             The string can be output to a file and then the file can
838             be sourced to produce a plot.
839             It depends upon the rgl library [http://cran.r-project.org/web/packages/rgl/index.html].
840              
841             $tbl->as_plot('R');
842              
843             user$ a.out > file.R
844             user$ R
845              
846             > source('file.R')
847              
848             (plot displayed)
849              
850             =head3 WANTED: more plot types: gnuplot, etc
851              
852              
853             =cut
854              
855             sub as_plot {
856 0     0 1   my $self = shift;
857 0           my $type = shift;
858              
859 0           my $str = '';
860              
861 0 0         if ($type eq 'R') {
862 0           my (@x, @y, @z);
863              
864 0           $str .= "\n";
865 0           $str .= "#\n";
866 0           $str .= "# This was generated by Text::LookUpTable->as_plot() function.\n";
867 0           $str .= "#\n";
868 0           $str .= "# start up R and then load this file by typing:\n";
869 0           $str .= "# source()\n";
870 0           $str .= "#\n";
871 0           $str .= "\n";
872 0           $str .= "library(rgl);\n";
873 0           $str .= "\n";
874              
875 0           my @xc = $self->get_x_coords();
876 0           my @yc = $self->get_y_coords();
877 0           my $num_x = @xc;
878 0           my $num_y = @yc;
879              
880              
881 0           for (my $i = 0; $i < @xc; $i++) {
882 0           for (my $j = 0; $j < @yc; $j++) {
883 0           my $val = $self->get($i, $j);
884 0           push @x, $xc[$i];
885 0           push @y, $yc[$i];
886 0           push @z, $val;
887             }
888             }
889              
890             # R expects the x, y axis data to be increasing
891             # Currently the y axis is the opposite
892             # The data can be reversed just to get the plot to work
893             # but this disrupts the data.
894 0           @yc = reverse @yc;
895              
896 0           $str .= "\n";
897 0           $str .= "x <- c(" . (join ", ", @xc) . ");\n";
898 0           $str .= "y <- c(" . (join ", ", @yc) . ");\n";
899 0           $str .= "z <- c(" . (join ", ", @z) . ");\n";
900 0           $str .= "dim(z) <- c(" . $num_x . ", " . $num_y . ")\n";
901 0           $str .= "\n";
902 0           $str .= "open3d()\n";
903 0           $str .= "bg3d(\"white\")\n";
904 0           $str .= "material3d(\"black\")\n";
905 0           $str .= "\n";
906 0           $str .= "persp3d(x, y, z, col=\"lightblue\", xlab=\"rpm\", ylab=\"map\", zlab=\"ign\")\n";
907             }
908              
909 0           return $str;
910             }
911              
912             # }}}
913              
914             =head1 PREREQUISITES
915              
916             Module Version
917             ------ -------
918             Text::Aligner 0.03
919             File::Slurp 9999.13
920            
921             The version numbers given have been tested and shown to work
922             but other versions may work as well.
923              
924             =head1 VERSION
925              
926             This document refers to Text::LookUpTable version 0.05.
927              
928             =head1 REFERENCES
929              
930             [1] MegaSquirt Engine Management System
931             http://www.msextra.com/
932              
933             [2] R Project
934             http://www.r-project.org/
935              
936             [3] rgl: 3D visualization device system (OpenGL)
937             http://cran.r-project.org/web/packages/rgl/index.html
938              
939             [4] Gnuplot
940             http://www.gnuplot.info/
941              
942             =head1 AUTHOR
943              
944             Jeremiah Mahler
945             CPAN ID: JERI
946             http://www.google.com/profiles/jmmahler#about
947              
948             =head1 COPYRIGHT
949              
950             Copyright (c) 2010, Jeremiah Mahler. All Rights Reserved.
951             This module is free software. It may be used, redistributed
952             and/or modified under the same terms as Perl itself.
953              
954             =cut
955              
956             # vim:foldmethod=marker
957              
958             1;