File Coverage

blib/lib/Algorithm/Numerical/Sample.pm
Criterion Covered Total %
statement 18 61 29.5
branch 0 20 0.0
condition 0 3 0.0
subroutine 6 10 60.0
pod 1 1 100.0
total 25 95 26.3


line stmt bran cond sub pod time code
1             package Algorithm::Numerical::Sample;
2              
3 2     2   61921 use 5.006;
  2         8  
  2         91  
4              
5 2     2   11 use strict;
  2         4  
  2         73  
6 2     2   10 use warnings;
  2         14  
  2         72  
7 2     2   11 no warnings 'syntax';
  2         2  
  2         87  
8 2     2   11 use Exporter ();
  2         2  
  2         690  
9              
10             our @ISA = qw /Exporter/;
11             our @EXPORT = qw //;
12             our @EXPORT_OK = qw /sample/;
13              
14             our $VERSION = '2010011201';
15              
16             my @PARAMS = qw /set sample_size/;
17             sub sample {
18 0     0 1   my %args = @_;
19              
20             # Deal with - parameters.
21 0           foreach (@PARAMS) {
22 0 0         $args {$_} = $args {"-$_"} unless defined $args {$_};
23             }
24              
25             # Check for set parameter.
26 0 0         die "sample requires the set parameter" unless $args {set};
27              
28 0           my $set = $args {set};
29              
30             # Set sample and set size.
31 0 0         my $sample_size = defined $args {sample_size} ? $args {sample_size} : 1;
32 0           my $set_size = @$set;
33              
34             # Reservoir will be our sample.
35 0           my @reservoir = (undef) x $sample_size;
36              
37             # Initialize counters.
38 0           my $sample_counter = 0;
39 0           my $set_counter = 0;
40              
41             # Loop as long as the reservoir isn't filled.
42 0           while ($sample_counter < $sample_size) {
43             # Draw a random number.
44 0           my $U = rand ($set_size - $set_counter);
45 0 0         if ($U < $sample_size - $sample_counter) {
46             # Select the next element with probability
47             # $sample_size - $sample_counter
48             # ------------------------------
49             # $set_size - $set_counter
50 0           $reservoir [$sample_counter ++] = $set -> [$set_counter];
51             }
52 0           $set_counter ++;
53             }
54              
55 0 0         wantarray ? @reservoir : \@reservoir;
56             }
57              
58              
59              
60             package Algorithm::Numerical::Sample::Stream;
61              
62 2     2   11 use strict;
  2         4  
  2         865  
63              
64              
65             sub new {
66 0     0     my $proto = shift;
67 0   0       my $class = ref $proto || $proto;
68 0           my %args = @_;
69              
70 0           foreach (qw /sample_size/) {
71 0 0         $args {$_} = $args {"-$_"} unless defined $args {$_};
72             }
73              
74 0           my $self = {};
75              
76 0 0         $self -> {sample_size} = defined $args {sample_size} ? $args {sample_size}
77             : 1;
78 0           $self -> {seen} = 0;
79 0           $self -> {reservoir} = [(undef) x $self -> {sample_size}];
80              
81 0           bless $self, $class;
82             }
83              
84             sub data {
85 0     0     my $self = shift;
86              
87 0           foreach my $sample (@_) {
88 0 0         if ($self -> {seen} < $self -> {sample_size}) {
89             # Initialize reservoir.
90 0           $self -> {reservoir} -> [$self -> {seen}] =
91             [$self -> {seen}, $sample];
92             }
93             else {
94             # Draw number.
95 0           my $U = int rand ($self -> {seen} + 1);
96 0 0         if ($U < $self -> {sample_size}) {
97 0           $self -> {reservoir} -> [$U] = [$self -> {seen}, $sample];
98             }
99             }
100              
101 0           $self -> {seen} ++;
102             }
103              
104 0           return;
105             }
106              
107             sub extract {
108 0     0     my $self = shift;
109              
110 0           my @result = map {$_ -> [1]}
  0            
111 0           sort {$a -> [0] <=> $b -> [0]} @{$self -> {reservoir}};
  0            
112              
113 0           $self -> {seen} = 0;
114 0           $self -> {reservoir} = [(undef) x $self -> {sample_size}];
115              
116 0 0         wantarray ? @result : $result [0];
117             }
118              
119              
120             __END__