File Coverage

blib/lib/Fsdb/Filter/dbcolpercentile.pm
Criterion Covered Total %
statement 27 139 19.4
branch 0 48 0.0
condition 0 6 0.0
subroutine 9 26 34.6
pod 5 5 100.0
total 41 224 18.3


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             #
4             # dbcolpercentile.pm
5             # Copyright (C) 1997-2015 by John Heidemann
6             # $Id: 704e422c1523fc35e78835d5885f028f9368c7ea $
7             #
8             # This program is distributed under terms of the GNU general
9             # public license, version 2. See the file COPYING
10             # in $dblibdir for details.
11             #
12              
13             package Fsdb::Filter::dbcolpercentile;
14              
15             =head1 NAME
16              
17             dbcolpercentile - compute percentiles or ranks for an existing column
18              
19             =head1 SYNOPSIS
20              
21             dbcolpercentile [-rplhS] column
22              
23             =head1 DESCRIPTION
24              
25             Compute a percentile of a column of numbers.
26             The new column will be called I or I.
27             Non-numeric records are handled as in other programs.
28              
29             If the data is pre-sorted and only a rank is requested,
30             no extra storage is required.
31             In all other cases, a full copy of data is buffered on disk.
32              
33             =head1 OPTIONS
34              
35             =over 4
36              
37             =item B<-p> or B<--percentile>
38              
39             Show percentile (default).
40              
41             =item B<-P> or B<--rank> or B<--nopercentile>
42              
43             Compute ranks instead of percentiles.
44              
45             =item B<--fraction>
46              
47             Show fraction (percentage, except between 0 and 1, not cumulative fraction).
48              
49             =item B<-a> or B<--include-non-numeric>
50              
51             Compute stats over all records (treat non-numeric records
52             as zero rather than just ignoring them).
53              
54             =item B<-S> or B<--pre-sorted>
55              
56             Assume data is already sorted.
57             With one -S, we check and confirm this precondition.
58             When repeated, we skip the check.
59              
60             =item B<-f FORMAT> or B<--format FORMAT>
61              
62             Specify a L-style format for output statistics.
63             Defaults to C<%.5g>.
64              
65             =item B<-T TmpDir>
66              
67             where to put tmp files.
68             Also uses environment variable TMPDIR, if -T is
69             not specified.
70             Default is /tmp.
71              
72             =back
73              
74             Sort specification options (can be interspersed with column names):
75              
76             =over 4
77              
78             =item B<-r> or B<--descending>
79              
80             sort in reverse order (high to low)
81              
82             =item B<-R> or B<--ascending>
83              
84             sort in normal order (low to high)
85              
86             =item B<-n> or B<--numeric>
87              
88             sort numerically (default)
89              
90             =item B<-N> or B<--lexical>
91              
92             sort lexicographically
93              
94             =back
95              
96             =for comment
97             begin_standard_fsdb_options
98              
99             This module also supports the standard fsdb options:
100              
101             =over 4
102              
103             =item B<-d>
104              
105             Enable debugging output.
106              
107             =item B<-i> or B<--input> InputSource
108              
109             Read from InputSource, typically a file name, or C<-> for standard input,
110             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
111              
112             =item B<-o> or B<--output> OutputDestination
113              
114             Write to OutputDestination, typically a file name, or C<-> for standard output,
115             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
116              
117             =item B<--autorun> or B<--noautorun>
118              
119             By default, programs process automatically,
120             but Fsdb::Filter objects in Perl do not run until you invoke
121             the run() method.
122             The C<--(no)autorun> option controls that behavior within Perl.
123              
124             =item B<--help>
125              
126             Show help.
127              
128             =item B<--man>
129              
130             Show full manual.
131              
132             =back
133              
134             =for comment
135             end_standard_fsdb_options
136              
137              
138             =head1 SAMPLE USAGE
139              
140             =head2 Input:
141              
142             #fsdb name id test1
143             a 1 80
144             b 2 70
145             c 3 65
146             d 4 90
147             e 5 70
148             f 6 90
149              
150             =head2 Command:
151              
152             cat DATA/grades.fsdb | dbcolpercentile test1
153              
154             =head2 Output:
155              
156             #fsdb name id test1 percentile
157             d 4 90 1
158             f 6 90 1
159             a 1 80 0.66667
160             b 2 70 0.5
161             e 5 70 0.5
162             c 3 65 0.16667
163             # | dbsort -n test1
164             # | dbcolpercentile test1
165              
166             =head2 Command 2:
167              
168             cat DATA/grades.fsdb | dbcolpercentile --rank test1
169              
170             =head2 Output 2:
171              
172             #fsdb name id test1 rank
173             d 4 90 1
174             f 6 90 1
175             a 1 80 3
176             b 2 70 4
177             e 5 70 4
178             c 3 65 6
179             # | dbsort -n test1
180             # | dbcolpercentile --rank test1
181              
182              
183             =head1 SEE ALSO
184              
185             L.
186             L.
187              
188              
189             =head1 CLASS FUNCTIONS
190              
191             =cut
192              
193             @ISA = qw(Fsdb::Filter);
194             $VERSION = 2.0;
195              
196 1     1   5307 use strict;
  1         4  
  1         27  
197 1     1   6 use Pod::Usage;
  1         2  
  1         81  
198 1     1   6 use Carp;
  1         1  
  1         48  
199              
200              
201 1     1   5 use Fsdb::Filter;
  1         2  
  1         20  
202 1     1   4 use Fsdb::Filter::dbpipeline qw(dbpipeline_filter dbsort);
  1         2  
  1         69  
203 1     1   6 use Fsdb::IO::Reader;
  1         2  
  1         17  
204 1     1   4 use Fsdb::IO::Writer;
  1         2  
  1         24  
205 1     1   5 use Fsdb::Support qw($is_numeric_regexp);
  1         1  
  1         83  
206 1     1   6 use Fsdb::Support::NamedTmpfile;
  1         2  
  1         1077  
207              
208              
209             =head2 new
210              
211             $filter = new Fsdb::Filter::dbcolpercentile(@arguments);
212              
213             Create a new dbcolpercentile object, taking command-line arguments.
214              
215             =cut
216              
217             sub new ($@) {
218 0     0 1   my $class = shift @_;
219 0           my $self = $class->SUPER::new(@_);
220 0           bless $self, $class;
221 0           $self->set_defaults;
222 0           $self->parse_options(@_);
223 0           $self->SUPER::post_new();
224 0           return $self;
225             }
226              
227              
228             =head2 set_defaults
229              
230             $filter->set_defaults();
231              
232             Internal: set up defaults.
233              
234             =cut
235              
236             sub set_defaults ($) {
237 0     0 1   my($self) = @_;
238 0           $self->SUPER::set_defaults();
239 0           $self->{_mode} = 'percentile';
240 0           $self->{_sort_order} = undef;
241 0           $self->{_sort_as_numeric} = 1;
242 0           $self->{_include_non_numeric} = undef;
243 0           $self->{_pre_sorted} = 0;
244 0           $self->{_target_column} = undef;
245 0           $self->{_save_in_filename} = undef;
246 0           $self->{_format} = "%.5g";
247 0           $self->set_default_tmpdir;
248             }
249              
250             =head2 parse_options
251              
252             $filter->parse_options(@ARGV);
253              
254             Internal: parse command-line arguments.
255              
256             =cut
257              
258             sub parse_options ($@) {
259 0     0 1   my $self = shift @_;
260              
261 0           my(@argv) = @_;
262             $self->get_options(
263             \@argv,
264 0     0     'help|?' => sub { pod2usage(1); },
265 0     0     'man' => sub { pod2usage(-verbose => 2); },
266             'a|include-non-numeric!' => \$self->{_include_non_numeric},
267             'autorun!' => \$self->{_autorun},
268             'd|debug+' => \$self->{_debug},
269             'f|format=s' => \$self->{_format},
270 0     0     'i|input=s' => sub { $self->parse_io_option('input', @_); },
271             'log!' => \$self->{_logprog},
272 0     0     'o|output=s' => sub { $self->parse_io_option('output', @_); },
273 0     0     'fraction' => sub { $self->{_mode} = 'fraction'; },
274 0     0     'p|percentile' => sub { $self->{_mode} = 'percentile'; },
275 0     0     'P|nopercentile|rank' => sub { $self->{_mode} = 'rank'; },
276             'S|pre-sorted+' => \$self->{_pre_sorted},
277             'T|tmpdir|tempdir=s' => \$self->{_tmpdir},
278             # sort key options:
279 0     0     'n|numeric' => sub { $self->{_sort_as_numeric} = 1; },
280 0     0     'N|lexical' => sub { $self->{_sort_as_numeric} = undef; },
281 0     0     'r|descending' => sub { $self->{_sort_order} = -1; },
282 0     0     'R|ascending' => sub { $self->{_sort_order} = 1; },
283 0 0         ) or pod2usage(2);
284 0           $self->parse_target_column(\@argv);
285             }
286              
287             =head2 setup
288              
289             $filter->setup();
290              
291             Internal: setup, parse headers.
292              
293             =cut
294              
295             sub setup ($) {
296 0     0 1   my($self) = @_;
297              
298             # assign default sort order, if not specified
299 0 0         if (!defined($self->{_sort_order})) {
300 0           $self->{_sort_order} = -1;
301 0 0         warn "defaulting sort order to " . ($self->{_sort_order} == 1 ? "ascending" : "descending") . "\n" if ($self->{_debug});
    0          
302             };
303              
304             #
305             # input
306             #
307             # guarantee data is sorted
308             # (swap reader if necessary)
309 0 0         if ($self->{_pre_sorted}) {
310             # pre-sorted, so just read it
311 0           $self->finish_io_option('input', -comment_handler => $self->create_delay_comments_sub);
312 0           $self->{_sorter_fred} = undef;
313             } else {
314             # not sorted, so sort it and read that
315 0           my @sort_args = ('--nolog', $self->{_target_column});
316 0 0         unshift(@sort_args, '--descending') if ($self->{_sort_order} == -1);
317 0 0         unshift(@sort_args, ($self->{_sort_as_numeric} ? '--numeric' : '--lexical'));
318 0           my($new_reader, $new_fred) = dbpipeline_filter($self->{_input}, [-comment_handler => $self->create_delay_comments_sub], dbsort(@sort_args));
319 0           $self->{_pre_sorted_input} = $self->{_input};
320 0           $self->{_in} = $new_reader;
321 0           $self->{_sorter_fred} = $new_fred;
322             };
323 0           $self->{_target_coli} = $self->{_in}->col_to_i($self->{_target_column});
324             croak $self->{_prog} . ": target column " . $self->{_target_column} . " is not in input stream.\n"
325 0 0         if (!defined($self->{_target_coli}));
326              
327             #
328             # output
329             #
330 0           $self->{_destination_column} = $self->{_mode};
331             croak $self->{_prog} . ": internal error: bad rank mode\n"
332 0 0         if (!defined($self->{_destination_column}));
333              
334 0           $self->finish_io_option('output', -clone => $self->{_in}, -outputheader => 'delay');
335             $self->{_out}->col_create($self->{_destination_column})
336 0 0         or croak $self->{_prog} . ": cannot create column '" . $self->{_destination_column} . "' (maybe it already existed?)\n";
337 0           $self->{_destination_coli} = $self->{_out}->col_to_i($self->{_destination_column});
338             }
339              
340             =head2 _count_rows
341              
342             $n = $self->_count_rows()
343              
344             Interpose a filter on C<$self->{_in}> that counts the rows.
345              
346             =cut
347             sub _count_rows() {
348 0     0     my($self) = shift @_;
349              
350 0           my $orig_in = $self->{_in};
351 0           $self->{_save_in_filename} = Fsdb::Support::NamedTmpfile::alloc($self->{_tmpdir});
352 0           my($save_sink) = new Fsdb::IO::Writer(-file => $self->{_save_in_filename}, -clone => $orig_in);
353 0           my($n) = 0;
354 0           my $read_fastpath_sub = $orig_in->fastpath_sub();
355 0           my $write_fastpath_sub = $save_sink->fastpath_sub();
356 0           my $fref;
357 0           while ($fref = &$read_fastpath_sub()) {
358 0           $n++;
359 0           &$write_fastpath_sub($fref);
360             };
361 0 0         $save_sink->error and croak $self->{_prog} . ": error writing temporary file.\n";
362 0           $save_sink->close;
363              
364             # reopen _in with our saved data
365 0           $self->{_in} = new Fsdb::IO::Reader(-file => $self->{_save_in_filename});
366 0           return $n;
367             }
368              
369             =head2 run
370              
371             $filter->run();
372              
373             Internal: run over each rows.
374              
375             =cut
376             sub run ($) {
377 0     0 1   my($self) = @_;
378              
379 0           my $percentile_scaling = 1;
380 0           my $n;
381 0 0         if ($self->{_mode} eq 'percentile') {
382 0           $n = $self->_count_rows;
383 0           $percentile_scaling = 1.0 / $n;
384             };
385              
386 0           my $read_fastpath_sub = $self->{_in}->fastpath_sub();
387 0           my $write_fastpath_sub = $self->{_out}->fastpath_sub();
388 0           my $fref;
389 0           my($mode) = $self->{_mode};
390 0 0         my $i = ($mode eq 'rank' ? 1 : 0);
391 0           my $result; # this row
392 0           my $last = undef;
393 0           my $in_run = undef;
394 0           my $run_i = undef;
395 0           my $x;
396 0           my($xf) = $self->{_target_coli};
397 0           my($of) = $self->{_destination_coli};
398 0 0         my($check_sort_order) = ($self->{_pre_sorted} == 1) ? $self->{_sort_order} : undef;
399 0 0 0       warn "will check sort order for " . $self->{_sort_order} . ".\n" if ($self->{_debugt} && $check_sort_order);
400              
401 0           while ($fref = &$read_fastpath_sub()) {
402              
403 0           $x = $fref->[$xf];
404 0           $result = $i++;
405 0 0         if ($mode eq 'percentile') {
406 0           $result = ($n - $result) * $percentile_scaling;
407 0           $result = $self->numeric_formatting($result);
408             };
409              
410 0 0         if ($x !~ /$is_numeric_regexp/) {
411 0           $last = undef; # non-numeric always ends run
412             } else {
413             # check for runs
414 0 0 0       if (defined($last) && $x == $last) {
415             # in a run
416 0           $result = $run_i;
417 0           $in_run = 1;
418             } else {
419             # sanity check
420 0 0         if ($check_sort_order) {
421 0 0         if (defined($last)) {
422 0           my $order = ($x <=> $last);
423 0 0         croak $self->{_prog} . ": data out of order between $last and $x, should be in " . ($check_sort_order == -1 ? "descending" : "ascending") . " order.\n"
    0          
424             if ($order != $check_sort_order);
425             };
426             };
427             # change
428 0           $last = $x;
429 0           $in_run = undef;
430             };
431             };
432              
433 0           $fref->[$of] = $result;
434 0 0         $run_i = $result if (! $in_run);
435              
436 0           &$write_fastpath_sub($fref);
437             };
438              
439 0 0         if (defined($self->{_sorter_fred})) {
440 0           $self->{_sorter_fred}->join();
441 0           $self->{_sorter_fred} = undef;
442             };
443             }
444              
445              
446             =head1 AUTHOR and COPYRIGHT
447              
448             Copyright (C) 1991-2015 by John Heidemann
449              
450             This program is distributed under terms of the GNU general
451             public license, version 2. See the file COPYING
452             with the distribution for details.
453              
454             =cut
455              
456             1;