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   31549 use 5.008001;
  3         8  
  3         94  
3 3     3   13 use strict;
  3         2  
  3         91  
4 3     3   21 use warnings;
  3         4  
  3         90  
5              
6 3     3   1455 use Moo;
  3         36071  
  3         16  
7 3     3   5396 use MooX::Types::MooseLike::Base qw( ArrayRef HashRef Num Int Str );
  3         15542  
  3         268  
8 3     3   1505 use namespace::clean;
  3         29222  
  3         19  
9 3     3   696 use Carp;
  3         5  
  3         1883  
10              
11             our $VERSION = "0.04";
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 31 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 7 my $self = shift;
47 6         6 my $prefix = shift;
48 6         5 my $seq = shift;
49              
50 6 50       15 if (ref $seq eq "ARRAY") {
51 6         10 my $pattern = $self->extract($self->{minsup}, $seq);
52 6 50       11 if (ref $pattern eq "HASH") {
53            
54 6         5 foreach my $i (keys %{$pattern}) {
  6         18  
55 5         5 my $p = $i;
56 5 100       7 if ($prefix ne "") {
57 2         3 $p = join " ", ($prefix, $i);
58             }
59 5         17 my $count = (() = $p =~ /\s+/g);
60 5 50       10 if ($count >= $self->{len} - 1) {
61 5         9 $self->{out}{"$p"} = $pattern->{$i};
62             }
63 5         8 my $j = $self->projection($seq, $i);
64 5         15 $self->prefixspan($p, $j);
65             }
66             }
67             }
68             }
69              
70             sub extract {
71 6     6 0 7 my $self = shift;
72 6         5 my $minsup = shift;
73 6         5 my $seq = shift;
74 6         5 my $h;
75              
76 6         11 for (my $i = 0; $i < @$seq; $i++) {
77 13         25 my @dist = split /\s+/, $seq->[$i];
78 13         11 map {$h->{$_}++} @dist;
  25         44  
79             }
80 6         5 foreach my $i (keys %{$h}) {
  6         13  
81 15 100       22 if ($h->{$i} < $minsup) {
82 10         15 delete $h->{$i};
83             }
84             }
85              
86 6         11 return $h;
87             }
88              
89             sub projection {
90 5     5 0 19 my $self = shift;
91 5         5 my $seq = shift;
92 5         5 my $b = shift;
93 5         3 my $h;
94              
95 5         3 foreach my $i (@{$seq}) {
  5         8  
96 18         25 my @list = split /\s+/, $i;
97 18         34 for (my $j = 0; $j < @list; $j++) {
98 39 100       72 if ($list[$j] eq $b) {
99 14         16 splice @list, 0, ($j +1);
100 14 100       29 if (@list > 0) {
101 9         5 push @{$h}, join " ", @list;
  9         28  
102             }
103             }
104             }
105             }
106              
107 5         8 return $h;
108             }
109              
110              
111             1;
112             __END__