File Coverage

blib/lib/Text/NumericData/App/txdcalc.pm
Criterion Covered Total %
statement 73 108 67.5
branch 21 48 43.7
condition 6 21 28.5
subroutine 11 13 84.6
pod 0 8 0.0
total 111 198 56.0


line stmt bran cond sub pod time code
1             package Text::NumericData::App::txdcalc;
2              
3 1     1   660 use Text::NumericData::App;
  1         2  
  1         33  
4 1     1   489 use Text::NumericData::File;
  1         3  
  1         34  
5 1     1   14 use Text::NumericData::Calc qw(formula_function);
  1         2  
  1         50  
6 1     1   420 use Text::NumericData::FileCalc qw(file_calc);
  1         2  
  1         61  
7              
8 1     1   7 use strict;
  1         2  
  1         1491  
9              
10             # This is just a placeholder because of a past build system bug.
11             # The one and only version for Text::NumericData is kept in
12             # the Text::NumericData module itself.
13             our $VERSION = '1';
14             $VERSION = eval $VERSION;
15              
16             #the infostring says it all
17             my $infostring = 'text data calculations
18              
19             Usage:
20             pipe | txdcalc [--] [files] | pipe
21              
22             It takes STDIN as primary data source and the files as secondary sources. Operation is line-wise in and out. So, this program is just a filter for data in ASCII files with quite some freedom in manipulating the data.
23             About formula syntax:
24             It is Perl, mostly. The variables (elements of corresponding rows) are denoted [n,m] in general. n is the file number (0 is the data from STDIN) and m the column (starting at 1). Short form [m] means implicitly n=0. Also there are $x or x for [0,1], $y or y for [0,2] and $z for [0,3].
25              
26             Additionally there are two arrays: A0, A1, A2, ... and C0, C1, C2, ... in the formula or references $A and $C in the plain Perl code. Both arrays are usable as you like (global scope) with the difference that @C gets initialized via the const parameter. Apart from the special syntax added here you can just use Perl to build advanced expressions, so that
27              
28             [3] = [1,2] != 0 ? [2]/[1,2] : 0
29              
30             catches the division by zero. You can switch to plain Perl syntax, too (see --plainperl).
31              
32             To discard a data line, place a "return 1" (or some other true --- not 0 or undefined --- value):
33              
34             return 1 if [3] != 85000;
35              
36             will only include data lines with the third column being equal to 85000.
37             ';
38              
39             our @ISA = ('Text::NumericData::App');
40              
41             sub new
42             {
43 1     1 0 104 my $class = shift;
44              
45             # Note: deleted the feature of differing strictness for the several input files.
46             # As I did not need it in all these years, It's apparently not worth the hassle.
47 1         15 my @pars =
48             (
49             # 'file',undef,'f','file(s) with data to be brought together with STDIN (comma-separated... you do not have any filenames with commas, do you?)',
50             'filehead',0,'F',
51             'use header from file (use number starting at 1 for a file in provided list) - overriden by manual header'
52             ,'header',undef,'H',
53             'use this header instead (\n becomes an appropriate line end, end of string by itself) - this one overrides the others'
54             ,'stdhead',1,'s',
55             'use header from STDIN (overridden by other options)'
56             ,'byrow',0,'r',
57             'correlate data sets simply by row number (0 / 1)'
58             ,'bycol',1,'c',
59             'correlate data via this column in STDIN data(1..#columns)'
60             ,'fromcol',0,'l',
61             'specify diferent columns (commalist) for correlation for each input file'
62             ,'lin',0,'',
63             'shortcut for enforcing linear interpolation'
64             ,'spline',0,'',
65             'shortcut for enforcing spline interpolation (overrules --lin)'
66             ,'headcode','','C',
67             'FullFun: Some code that gets eval()ed with possibility to parse/modify every head line (variable $line; line number is $num).'
68             ,'aftercode','','A',
69             'FullFun: Some code that gets eval()ed after the input file is through (only useful together with justcalc and ignored otherwise)'
70             ,'beforecode','','B',
71             'FullFun: Some code that gets eval()ed before input processing (yes, first B, then A, because B[efore] A[fter];-)'
72             ,'formula',undef,'m',
73             'specify formula here or as first command line parameter'
74             ,'const',undef,'n',
75             'specify a constant array (separated by spaces)'
76             ,'debug',0,'d',
77             'give some info that may help debugging'
78             ,'justcalc',0,'j',
79             'just print values of the A array after calculation and not the resulting data (for simply doing some calculation like summing, averaging...)'
80             ,'plainperl',0,'',
81             'Use plain Perl syntax for formula for full force without confusing the intermediate parser.'
82             );
83              
84 1         17 return $class->SUPER::new
85             ({
86             parconf =>
87             {
88             info=>$infostring
89             # default copyright
90             # default version
91             }
92             ,pardef => \@pars
93             ,pipemode => 1
94             ,pipe_init => \&preinit
95             ,pipe_begin => \&init
96             ,pipe_header => \&process_header
97             ,pipe_data => \&process_data
98             ,pipe_end => \&endoffile
99             });
100             }
101              
102              
103             sub preinit
104             {
105 6     6 0 16 my $self = shift;
106 6         11 my $param = $self->{param};
107              
108 6 50       19 $param->{interpolate} = 'linear' if $param->{lin};
109 6 50       14 $param->{interpolate} = 'spline' if $param->{spline};
110              
111 6 50       22 if(defined $param->{header}){ $param->{stdhead} = 0; $param->{filehead} = 0; }
  0 50       0  
  0         0  
112 0         0 elsif($param->{filehead}){ $param->{stdhead} = 0; }
113              
114             # That should return an error, shouldn't it?\
115             # Changed it so.
116 6 50 33     20 if(!defined $param->{formula} and !@{$self->{argv}}){ print STDERR "That's not enough... see $0 --help\n"; return -1; }
  6         31  
  0         0  
  0         0  
117              
118 6         94 $self->{files} = [];
119 6 50       15 my $form = defined $param->{formula} ? $param->{formula} : shift(@{$self->{argv}});
  6         18  
120              
121             #remember: on the outside col 1..cols; inside 0..cols-1 !
122 6 100       15 unless($param->{byrow})
123             {
124 5 50       24 if($param->{bycol} < 1)
125             {
126 0         0 print STDERR "invalid column for correlation!\n";
127 0         0 return -1;
128             }
129 5         12 --$param->{bycol};
130             }
131 6 50       21 $self->{fromcol} = $param->{fromcol} ? [split(',', $param->{fromcol})] : [];
132 6         9 my $si = 0;
133              
134 6         11 for(@{$self->{argv}})
  6         15  
135             {
136 6         48 my $f = Text::NumericData::File->new($param, $_);
137 6         14 push(@{$self->{files}}, $f);
  6         17  
138 6         12 my $lastf = $#{$self->{files}};
  6         18  
139             print STDERR "Warning: Got no data out of $_!\n"
140 6 50       10 unless @{$f->{data}};
  6         25  
141 6 50       26 $self->{fromcol}[$lastf] = defined $self->{fromcol}[$lastf] ? $self->{fromcol}[$lastf]-1 : $param->{bycol};
142             print STDERR "warning: $_ doesn't have a column $self->{fromcol}[$lastf]\n"
143 6 50 33     32 if($self->{fromcol}[$lastf] < 0 or $self->{fromcol}[$lastf] >= $self->{files}[$lastf]->columns())
144             }
145              
146 6 0 0     20 if($param->{filehead} and ($param->{filehead} > @{$self->{files}} or $param->{filehead} < 0))
      33        
147             {
148 0         0 print STDERR "Invalid file number for header!\n";
149 0         0 return -1;
150             }
151              
152             # Formula function with configuration for file_calc, only row offset is changed per line.
153 6         42 $self->{ff} = formula_function($form,{verbose=>$param->{debug},plainperl=>$param->{plainperl}});
154             $self->{ffconf} =
155             {
156             bycol => $param->{bycol}
157             , fromcol => $self->{fromcol}
158             , byrow => $param->{byrow}
159 6         55 , skipempty => 1 # They're skipped before, anyway ...
160             , rowoffset => 0
161             };
162              
163 6 50       33 unless(defined $self->{ff})
164             {
165 0         0 print STDERR "Error in formula!\n";
166 0         0 return -1;
167             }
168 6 50       21 $self->{C} = defined $param->{const} ? [split(' ', $param->{const})] : [];
169 6         8 foreach my $c (@{$self->{C}})
  6         37  
170             {
171             # Another such eval ... this one really is supposed to be context-free.
172 0         0 $c = eval $c;
173             }
174             }
175              
176             # Evil eval ... make it safer? Its purpose is to give endless possibilities, after all.
177             sub context_eval
178             {
179 6     6 0 12 my $self = shift;
180 6 50       29 return unless $self->{param}{$_[0]} ne '';
181              
182 0         0 my $A = $self->{A};
183 0         0 my $C = $self->{C};
184 0         0 eval $self->{param}{$_[0]};
185             }
186              
187             sub init
188             {
189 6     6 0 491 my $self = shift;
190 6         27 $self->new_txd();
191 6         23 $self->{row} = -1;
192 6         11 $self->{num} = 0;
193 6         15 $self->{A} = [];
194 6         14 $self->{parheader} = $self->{param}{header};
195 6         12 $self->{parfilehead} = $self->{param}{filehead};
196 6         32 $self->context_eval('beforecode');
197             }
198              
199             sub process_header
200             {
201 0     0 0 0 my $self = shift;
202 0         0 my $param = $self->{param};
203 0         0 ++$self->{num}; #increase head line counter
204 0         0 $self->context_eval('headcode');
205 0 0 0     0 $_[0] = '' unless($param->{stdhead} and not $param->{justcalc});
206              
207 0 0       0 unless($param->{justcalc})
208             {
209             #now we should at least know the line ending
210 0 0       0 if(defined $self->{parheader})
    0          
211             {
212 0         0 $self->{parheader} =~ s/\\n/$self->{txd}{config}{lineend}/g;
213 0         0 $_[0] = $self->{parheader}.$self->{txd}{config}{lineend};
214 0         0 $self->{parheader} = undef;
215             }
216             elsif($self->{parfilehead})
217             {
218 0         0 $_[0] = '';
219 0         0 foreach my $l (@{$self->{files}[$self->{parfilehead}-1]->{raw_header}})
  0         0  
220             {
221 0         0 $_[0] .= $l.$self->{txd}{config}{lineend};
222             }
223 0         0 $self->{parfilehead} = 0;
224             }
225             }
226              
227             }
228              
229             sub process_data
230             {
231 420     420 0 616 my $self = shift;
232 420         681 my $param = $self->{param};
233              
234             # Preserve empty lines that may have a meaning
235             # In strict mode, though, multiple spaces may have meaning,
236             # so let's have file_calc() worry about ignoring.
237 420 50 33     2010 if(not $param->{strict} and $_[0] =~ /^\s*$/){ return; }
  0         0  
238              
239 420         1187 my $data = $self->{txd}->line_data($_[0]);
240 420         818 $self->{ffconf}{rowoffset} = ++$self->{row};
241              
242             # Doing calculation for a fake file with one data set only.
243             # This keeps the logic in one common place and also leads the
244             # mind to the idea of optional caching of lines and block operation.
245             # But, the semantics of one line in and one line out, immediately are
246             # probably not to change.
247             my $ignore = file_calc( $self->{ff}, $self->{ffconf}
248             , [$data] # Don't forget: This is the actual data we work on ...
249 420         1420 , $self->{files}, $self->{A}, $self->{C} );
250              
251             # On error, ignore the line. Else, the returned array has
252             # one entry if the line should be purposefully ignored.
253             my $nothing = defined $ignore
254 420 50       1019 ? @{$ignore} # == 0 normally
  420         731  
255             : 1;
256              
257             $_[0] = ($nothing or $param->{justcalc})
258             ? ''
259 420 100 66     1566 : ${$self->{txd}->data_line($data)};
  330         1052  
260             }
261              
262             sub endoffile
263             {
264 6     6 0 171 my $self = shift;
265             # Prepend a line with results.
266             # The line end should match input since it comes from the Text::NumericData instance.
267 6 50       24 $_[0] = ${$self->justcalc_result()}.$_[0] if $self->{param}{justcalc};
  0            
268             }
269              
270             sub justcalc_result
271             {
272 0     0 0   my $self = shift;
273 0           $self->context_eval('aftercode');
274 0           return $self->{txd}->data_line($self->{A});
275             }