File Coverage

blib/lib/Algorithm/Prefixspan.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package Algorithm::Prefixspan;
2 3     3   43888 use 5.008001;
  3         11  
  3         116  
3 3     3   16 use strict;
  3         5  
  3         124  
4 3     3   28 use warnings;
  3         5  
  3         99  
5              
6 3     3   1672 use Moo;
  3         44646  
  3         17  
7 3     3   12455 use MooX::Types::MooseLike::Base qw( ArrayRef HashRef Num Int Str );
  0            
  0            
8             use namespace::clean;
9             use Carp;
10              
11             our $VERSION = "0.02";
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             my $self = shift;
38              
39             $self->prefixspan("", $self->{data});
40              
41             return $self->{out};
42             }
43              
44              
45             sub prefixspan {
46             my $self = shift;
47             my $prefix = shift;
48             my $seq = shift;
49              
50             if (ref $seq eq "ARRAY") {
51             my $pattern = $self->extract($self->{minsup}, $seq);
52             if (ref $pattern eq "HASH") {
53            
54             foreach my $i (keys %{$pattern}) {
55             my $p = $i;
56             if ($prefix ne "") {
57             $p = join " ", ($prefix, $i);
58             }
59             my $count = (() = $p =~ /\s+/g);
60             if ($count >= $self->{len} - 1) {
61             $self->{out}{"$p"} = $pattern->{$i};
62             }
63             my $j = $self->projection($seq, $i);
64             $self->prefixspan($p, $j);
65             }
66             }
67             }
68             }
69              
70             sub extract {
71             my $self = shift;
72             my $minsup = shift;
73             my $seq = shift;
74             my $h;
75              
76             for (my $i = 0; $i < @$seq; $i++) {
77             my @dist = split /\s+/, $seq->[$i];
78             map {$h->{$_}++} @dist;
79             }
80             foreach my $i (keys %{$h}) {
81             if ($h->{$i} < $minsup) {
82             delete $h->{$i};
83             }
84             }
85              
86             return $h;
87             }
88              
89             sub projection {
90             my $self = shift;
91             my $seq = shift;
92             my $b = shift;
93             my $h;
94              
95             foreach my $i (@{$seq}) {
96             my @list = split /\s+/, $i;
97             for (my $j = 0; $j < @list; $j++) {
98             if ($list[$j] eq $b) {
99             splice @list, 0, ($j +1);
100             if (@list > 0) {
101             push @{$h}, join " ", @list;
102             }
103             }
104             }
105             }
106              
107             return $h;
108             }
109              
110              
111             1;
112             __END__