File Coverage

blib/lib/Algorithm/Prefixspan.pm
Criterion Covered Total %
statement 67 67 100.0
branch 11 14 78.5
condition n/a
subroutine 11 11 100.0
pod 0 4 0.0
total 89 96 92.7


line stmt bran cond sub pod time code
1             package Algorithm::Prefixspan;
2 3     3   49726 use 5.008001;
  3         12  
  3         243  
3 3     3   22 use strict;
  3         5  
  3         148  
4 3     3   30 use warnings;
  3         6  
  3         124  
5              
6 3     3   2335 use Moo;
  3         57799  
  3         20  
7 3     3   8627 use MooX::Types::MooseLike::Base qw( ArrayRef HashRef Num Int Str );
  3         23901  
  3         476  
8 3     3   2447 use namespace::clean;
  3         44956  
  3         24  
9 3     3   1217 use Carp;
  3         6  
  3         2586  
10              
11             our $VERSION = "0.03";
12              
13             has data => (
14             is => 'rw',
15             isa => ArrayRef,
16             required => 1,
17             );
18              
19             has out => (
20             is => 'rw',
21             isa => HashRef,
22             );
23              
24             has minsup => (
25             is => 'rw',
26             isa => Int,
27             default => sub { 2 },
28             );
29              
30             has len => (
31             is => 'rw',
32             isa => Int,
33             default => sub { 1 },
34             );
35              
36             sub run {
37 1     1 0 52 my $self = shift;
38              
39 1         5 $self->prefixspan("", $self->{data});
40              
41 1         4 return $self->{out};
42             }
43              
44              
45             sub prefixspan {
46 6     6 0 8 my $self = shift;
47 6         10 my $prefix = shift;
48 6         7 my $seq = shift;
49              
50 6 50       17 if (ref $seq eq "ARRAY") {
51 6         18 my $pattern = $self->extract($self->{minsup}, $seq);
52 6 50       17 if (ref $pattern eq "HASH") {
53            
54 6         6 foreach my $i (keys %{$pattern}) {
  6         27  
55 5         6 my $p = $i;
56 5 100       11 if ($prefix ne "") {
57 2         5 $p = join " ", ($prefix, $i);
58             }
59 5         20 my $count = (() = $p =~ /\s+/g);
60 5 50       21 if ($count >= $self->{len} - 1) {
61 5         12 $self->{out}{"$p"} = $pattern->{$i};
62             }
63 5         11 my $j = $self->projection($seq, $i);
64 5         23 $self->prefixspan($p, $j);
65             }
66             }
67             }
68             }
69              
70             sub extract {
71 6     6 0 8 my $self = shift;
72 6         7 my $minsup = shift;
73 6         5 my $seq = shift;
74 6         6 my $h;
75              
76 6         17 for (my $i = 0; $i < @$seq; $i++) {
77 13         34 my @dist = split /\s+/, $seq->[$i];
78 13         18 map {$h->{$_}++} @dist;
  25         68  
79             }
80 6         9 foreach my $i (keys %{$h}) {
  6         19  
81 15 100       34 if ($h->{$i} < $minsup) {
82 10         20 delete $h->{$i};
83             }
84             }
85              
86 6         13 return $h;
87             }
88              
89             sub projection {
90 5     5 0 23 my $self = shift;
91 5         5 my $seq = shift;
92 5         6 my $b = shift;
93 5         5 my $h;
94              
95 5         6 foreach my $i (@{$seq}) {
  5         8  
96 18         45 my @list = split /\s+/, $i;
97 18         43 for (my $j = 0; $j < @list; $j++) {
98 39 100       101 if ($list[$j] eq $b) {
99 14         21 splice @list, 0, ($j +1);
100 14 100       37 if (@list > 0) {
101 9         9 push @{$h}, join " ", @list;
  9         37  
102             }
103             }
104             }
105             }
106              
107 5         10 return $h;
108             }
109              
110              
111             1;
112             __END__