File Coverage

blib/lib/Text/NumericData/App/txdcontract.pm
Criterion Covered Total %
statement 45 61 73.7
branch 10 20 50.0
condition 4 9 44.4
subroutine 6 6 100.0
pod 0 4 0.0
total 65 100 65.0


line stmt bran cond sub pod time code
1             package Text::NumericData::App::txdcontract;
2              
3 1     1   81966 use Text::NumericData::App;
  1         5  
  1         48  
4              
5 1     1   10 use strict;
  1         3  
  1         949  
6              
7             # This is just a placeholder because of a past build system bug.
8             # The one and only version for Text::NumericData is kept in
9             # the Text::NumericData module itself.
10             our $VERSION = '1';
11             $VERSION = eval $VERSION;
12              
13             #the infostring says it all
14             my $infostring = 'contract a data file by computing the mean over n input rows to produce one output row
15              
16             txdcontract 2 < 100rows.dat > 50rows.dat
17              
18             A partial bin at the end is dropped. When you choose value-based binning, there
19             will always be some data dropped at the end. That way, you only get mean values
20             that actually represent a full interval/bin. Furthermore, the input data is
21             assumed to be sorted according to the column chosen for value-based binning.';
22              
23             our @ISA = ('Text::NumericData::App');
24              
25             sub new
26             {
27 1     1 0 127 my $class = shift;
28 1         7 my @pars = (
29             'bincol', '', 'c'
30             , 'bin by values in given column instead of contracting by row count'
31             , 'binsize', 1, 'b', 'size of one bin'
32             );
33              
34 1         29 return $class->SUPER::new
35             ({
36             parconf =>
37             {
38             info=>$infostring # default version
39             # default author
40             # default copyright
41             }
42             ,pardef => \@pars
43             ,pipemode => 1
44             ,pipe_init => \&preinit
45             ,pipe_begin => \&init
46             ,pipe_data => \&process_data
47             });
48             }
49              
50             sub preinit
51             {
52 1     1 0 4 my $self = shift;
53 1         3 my $n = shift(@{$self->{argv}});
  1         6  
54 1         9 my $bincol = int($self->{param}{bincol});
55 1 50       6 if($bincol > 0)
56             {
57 0         0 $self->{bincol} = $bincol-1;
58 0 0       0 unless($self->{param}{binsize} > 0)
59             {
60 0         0 print STDERR "Need positive binsize!\n";
61 0         0 return -1;
62             }
63 0         0 $self->{binsize} = 0+$self->{param}{binsize};
64             }
65             else
66             {
67 1 50       6 unless(defined $n)
68             {
69 0         0 print STDERR "Need n as argument!\n";
70 0         0 return -1;
71             }
72 1 50       25 unless($n>0)
73             {
74 0         0 print STDERR "Need n>0!\n";
75 0         0 return -1;
76             }
77 1         5 $self->{n} = int($n);
78             }
79 1         6 return 0;
80             }
81              
82             sub init
83             {
84 1     1 0 154 my $self = shift;
85              
86 1         18 $self->new_txd();
87 1         4 $self->{binval} = undef;
88 1         5 $self->{mean} = [];
89 1 50       6 $self->{meancount} = defined $self->{n} ? $self->{n} : 0;
90 1         6 $self->{ln} = 0;
91             }
92              
93             sub process_data
94             {
95 4     4 0 12 my $self = shift;
96 4         20 my $data = $self->{txd}->line_data($_[0]);
97 4         12 my $bin_finished;
98             my $binval;
99 4         10 $_[0] = '';
100             return
101 4 50       14 unless defined $data;
102              
103             # Line-based binning knows already where the boundary is, can
104             # compute before output.
105 4 50       14 if(defined $self->{n})
106             {
107 4         11 for(my $i = 0; $i <= $#{$data}; ++$i)
  16         48  
108             {
109 12         40 $self->{mean}[$i] += $data->[$i];
110             }
111 4         12 ++$self->{ln};
112             }
113             else # Value-based binning needs to figure out if we crossed the border.
114             {
115             $binval = sprintf('%.0f', $data->[$self->{bincol}]/$self->{binsize})
116 0         0 * $self->{binsize};
117 0   0     0 $bin_finished = (@{$self->{mean}} and $binval != $self->{binval});
118             }
119              
120 4 100 66     37 if($bin_finished or (defined $self->{n} and $self->{ln} == $self->{n}))
      66        
121             {
122 2         6 for(my $i = 0; $i <= $#{$self->{mean}}; ++$i)
  8         29  
123             {
124 6         20 $self->{mean}[$i] /= $self->{ln};
125             }
126             $self->{mean}[$self->{bincol}] = $self->{binval}
127 2 50       8 if $bin_finished;
128 2         5 $_[0] = ${$self->{txd}->data_line($self->{mean})};
  2         11  
129 2         6 @{$self->{mean}} = ();
  2         9  
130 2         7 $self->{ln} = 0;
131             }
132              
133             # Need to add bin values after output. Slightly twisted logic compared to
134             # line-based binning.
135 4 50       22 unless(defined $self->{n})
136             {
137 0           $self->{binval} = $binval;
138 0           for(my $i = 0; $i <= $#{$data}; ++$i)
  0            
139             {
140 0           $self->{mean}[$i] += $data->[$i];
141             }
142 0           ++$self->{ln};
143             }
144             }
145              
146             1;