File Coverage

blib/lib/Text/NumericData/App/txdrecycle.pm
Criterion Covered Total %
statement 83 92 90.2
branch 22 36 61.1
condition 1 6 16.6
subroutine 10 10 100.0
pod 0 8 0.0
total 116 152 76.3


line stmt bran cond sub pod time code
1             package Text::NumericData::App::txdrecycle;
2              
3 1     1   71669 use Text::NumericData::App;
  1         15  
  1         41  
4              
5 1     1   7 use strict;
  1         7  
  1         1148  
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 = 'Rearrange lines (records) in files in accordance to changing the viewport along a cyclic coordinate.
15              
16             This is experimental work, so no usage example yet. But one hint: I designed this one with moving the viewport of gnuplot plots of cyclic data. It assumest sorted data along the coordinate (ascending or descending). To make it work with 3D plots, it processes blocks of data (separated by blank line) as independent "scans" (for gnuplot pm3d mode, for example).';
17              
18             our @ISA = ('Text::NumericData::App');
19              
20             sub new
21             {
22 1     1 0 100 my $class = shift;
23 1         7 my @pars =
24             (
25             'column', 1, 'c',
26             'the column to use as coordiante'
27             , 'shift', 0.25, 's',
28             'shift the viewport by that value (nearest existing data point), direction is subject to misunderstandings'
29             , 'smother', 0, 'm',
30             'compute arithmetic mean of initial outer boundaries that are supposed to be identical, but are not'
31             , 'smother-except', [], 'x',
32             'list of columns to extempt from smothering (in addition to the coordinate column)'
33             );
34 1         18 return $class->SUPER::new
35             ({
36             parconf=>
37             {
38             info=>$infostring # default version,
39             # default author
40             # default copyright
41             }
42             ,pardef=>\@pars
43             ,filemode=>0
44             ,pipemode=>1
45             ,pipe_init=>\&preinit
46             ,pipe_begin=>\&begin
47             ,pipe_line=>\&line
48             ,pipe_end=>\&end
49             });
50             }
51              
52             sub preinit
53             {
54 1     1 0 2 my $self = shift;
55 1         3 my $param = $self->{param};
56              
57 1         7 $self->{col} = $param->{column}-1;
58 1 50       5 if($self->{col} < 0)
59             {
60 0         0 print STDERR "txdrecycle: Non-positive column does not work!\n";
61 0         0 return -1;
62             }
63              
64 1         4 return 0;
65             }
66              
67             sub line
68             {
69 841     841 0 20887 my $self = shift;
70              
71 841 100       1718 if(not $self->{data})
72             {
73             $self->{data} = 1
74 3 100       11 if $self->{txd}->line_check($_[0]);
75             }
76              
77 841 100       1551 if($self->{data})
78             {
79 839 100       2239 if($_[0] =~ /^\s*$/)
80             {
81 13         24 my $future = $_[0];
82 13         21 $_[0] = '';
83 13         43 $self->finish_block($_[0]);
84 13         27 $_[0] .= $future;
85 13         35 return;
86             }
87              
88 826         1913 my $d = $self->{txd}->line_data($_[0]);
89 826 50       1577 if(defined $d)
90             {
91 826         1083 push(@{$self->{block}}, $d);
  826         1505  
92             }
93 826         1654 $_[0] = '';
94             }
95             }
96              
97             sub begin
98             {
99 1     1 0 140 my $self = shift;
100              
101 1         12 $self->new_txd();
102 1         4 $self->{block} = [];
103 1         4 $self->{data} = 0;
104             }
105              
106             sub end
107             {
108 1     1 0 46 my $self = shift;
109              
110 1         4 $self->finish_block($_[0]);
111             }
112              
113             sub finish_block
114             {
115 14     14 0 24 my $self = shift;
116 14         36 $self->recycle_block();
117              
118 826         2345 $_[0] .= ${$self->{txd}->data_line($_)}
119 14         42 for (@{$self->{block}});
  14         31  
120              
121             # Think about caching periods 'n' stuff and check consistency.
122 14         206 $self->{block} = [];
123             }
124              
125             # The scheme:
126             # shift 'abcdea' by 3 letters -> 'deabcd'
127             sub recycle_block
128             {
129 14     14 0 23 my $self = shift;
130 14         58 my $param = $self->{param};
131              
132             # Nothing to do for such small data sets... cannot possibly make any sense.
133             # I require the end points being identical, so to have something, there must be some data in between.
134 14 50       26 return if @{$self->{block}} < 2;
  14         34  
135              
136             # I support ascending and descending data.
137 14         26 my $period = $self->{block}[$#{$self->{block}}][$self->{col}] - $self->{block}[0][$self->{col}];
  14         82  
138 14 50       35 my $dir = $period > 0 ? +1 : -1;
139 14         26 $period = abs($period);
140              
141             # Yeah, that check is not very floating-point safe.
142 14 50       28 return unless $period > 0;
143              
144             # Shift needs to be oriented according to sorting order.
145 14         31 my $shift=$param->{shift}*$dir;
146             # Shift withing one period.
147 14         29 $shift -= int($shift/$period)*$period;
148             # ... but still, positive!
149 14 50       29 $shift += $period if $shift < 0;
150             #print STDERR "real shift: $shift\n";
151              
152             # The point of split, beginning plus shift.
153 14         31 my $i = nearest_index($self->{block}[0][$self->{col}]+$dir*$shift, $dir, \@{$self->{block}});
  14         104  
154             #print STDERR "wrap point: $i\n";
155 14 50 33     75 return if ($i == 0 or $i == $#{$self->{block}}); # No need to split there.
  14         50  
156              
157 14         23 my @a = @{$self->{block}}; # Remember, just a bunch of references.
  14         143  
158             # Need a copy before messing with the references.
159 14         23 my @boundary = @{$a[$i]};
  14         47  
160              
161             # Start filling the recycled data.
162 14         57 @{$self->{block}} = (@a[$i..$#a-1]);
  14         124  
163             # The data got moved one pace back, adjust coordinate.
164 14         52 $_->[$self->{col}] -= $dir*$period for (@{$self->{block}});
  14         395  
165             # Shove in the unchanged remaining data, plus the new boundary.
166             # $a[0] is supposed to the identical to $a[$#a]. But in might not be so,
167             # for a DG model, for example. Let's smother it a bit.
168 14 50       46 if($param->{smother})
169             {
170 0         0 my @except = ($self->{col}, @{$param->{'smother-except'}});
  0         0  
171 0         0 for(my $i = 0; $i< @{$a[0]}; ++$i)
  0         0  
172             {
173             $a[0][$i] = 0.5*($a[0][$i] + $a[$#a][$i])
174 0 0 0     0 if(not grep { $_ == $i } @except and $a[0][$i] != $a[$#a][$i]);
  0         0  
175             }
176             }
177 14         22 push(@{$self->{block}}, @a[0 .. $i-1]);
  14         43  
178 14         25 push(@{$self->{block}}, \@boundary);
  14         29  
179             # Bring the coordinates back into a sane range.
180             # Am I sure that this is correct? Caring for $dir is tedious.
181             # Examples:
182 14 50       62 if($dir*$self->{block}[0][$self->{col}] < -$period)
183             {
184             $_->[$self->{col}] += $dir*$period
185 14         22 for (@{$self->{block}});
  14         317  
186             }
187             }
188              
189             sub nearest_index
190             {
191 14     14 0 34 my ($val, $dir, $arr) = (@_);
192 14 50       38 my $lower = $dir == +1 ? 0 : $#{$arr};
  0         0  
193 14 50       28 my $upper = $dir == +1 ? $#{$arr} : 0;
  14         24  
194              
195             # Hacking around to get a loop that runs both ways...
196 14         39 for(my $i=$lower+$dir; $i!=$upper+$dir; $i+=$dir)
197             {
198 154 100       418 if($arr->[$i][0] >= $val)
199             {
200 14         25 $upper = $i;
201 14         20 $lower = $i-$dir;
202 14         26 last;
203             }
204             }
205 14 50       52 return ($val - $arr->[$lower][0] < $arr->[$upper][0] - $val) ? $lower : $upper;
206             }