File Coverage

blib/lib/AI/Fuzzy/Axis.pm
Criterion Covered Total %
statement 60 79 75.9
branch 13 26 50.0
condition 4 18 22.2
subroutine 10 12 83.3
pod 0 11 0.0
total 87 146 59.5


line stmt bran cond sub pod time code
1             package AI::Fuzzy::Axis;
2              
3 1     1   765 use AI::Fuzzy::Label;
  1         2  
  1         1440  
4             ## Container for Fuzzy Labels ####
5              
6             sub new {
7              
8 3     3 0 126 my ($class) = @_;
9 3         5 my $self = {};
10              
11 3         8 $self->{labels} = {};
12              
13 3         8 bless $self, $class;
14 3         7 return $self;
15             }
16              
17             sub addlabel {
18             # adds a label for a range of values..
19 21     21 0 133 my ($self, $label, $low, $mid, $high) = @_;
20              
21 21 50       112 if ($label->can("name") ) {
22 0         0 $self->{labels}->{$label->name} = $label;
23             } else {
24 21         61 $self->{labels}->{$label} = new AI::Fuzzy::Label($label, $low, $mid, $high);
25             }
26              
27 21         48 return $self->{labels}->{$label};
28             }
29              
30              
31             sub applicability {
32             # this function should be called something else..
33             # calculates to what degree $label applies to a $value
34              
35 1     1 0 64 my ($self, $value, $label) = @_;
36 1         2 my $membership = 0;
37              
38 1 50       12 return $label->applicability($value) if ($label->can("applicability"));
39 1 50       14 return undef unless ( exists $self->{labels}->{$label} );
40 1         7 return $self->{labels}->{$label}->applicability($value);
41             }
42              
43             sub label {
44             # returns a label associated with this text
45 6     6 0 60 my ($self, $name) = @_;
46              
47 6         20 return $self->{labels}->{$name};
48             }
49              
50             sub labelvalue {
51             # returns a label associated with this value
52 5     5 0 92 my ($self, $value) = @_;
53 5         6 my $label;
54             my %weight;
55 5         8 my $total_weight = 0;
56 5         10 my @range = $self->range();
57              
58              
59             # first, find out the applicability of each label
60             # and weight the labels accordingly.
61 5         12 foreach $label (@range) {
62 27         26 my $labelname ;
63             my $w;
64              
65 27 50       82 if ($label->can("name")) {
66 27         60 $labelname = $label->name;
67 27         64 $w = $label->applicability($value);
68             } else {
69 0         0 $labelname = $label;
70 0         0 $w = $self->applicability($value, $label);
71             }
72              
73 27 100       66 next unless $w > 0;
74              
75 7         13 $weight{$labelname} = $w;
76 7         15 $total_weight += $weight{$labelname};
77             }
78              
79             # in list context, just return the weights
80 5 100       12 if (wantarray) {
81 2         15 return %weight;
82             }
83              
84             # give up if no labels apply
85 3 50       7 return 0 unless $total_weight > 0;
86              
87             # otherwise, use those weights as probabilities
88             # and randomly pick a label:
89              
90 3         50 my $v = rand $total_weight;
91 3         4 my $x = 0;
92              
93             # it doesn't matter how %weight is sorted..
94 3         6 foreach $label (keys %weight) {
95 3         6 $x += $weight{$label};
96 3 50       20 return $self->{labels}->{$label} if $x >= $v;
97             }
98              
99             # and if none of that worked..
100              
101 0         0 return 0;
102             }
103              
104              
105             sub range {
106             # returns a list of sorted labels
107 5     5 0 6 my ($self) = @_;
108 5         10 my $l = $self->{labels};
109 5         6 return sort { $a <=> $b } values %{$l};
  35         75  
  5         22  
110             }
111              
112             sub lessthan {
113 1     1 0 26 my ($self, $labela, $labelb) = @_;
114              
115 1 50 33     9 if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb} ) {
116 1         2 my $la = $self->{labels}->{$labela};
117 1         39 my $lb = $self->{labels}->{$labelb};
118              
119 1         5 return $la->lessthan($lb);
120              
121             } else {
122 0         0 return undef;
123             }
124             }
125             sub lessequal {
126 0     0 0 0 my ($self, $labela, $labelb) = @_;
127              
128 0 0 0     0 if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb} ) {
129 0         0 my $la = $self->{labels}->{$labela};
130 0         0 my $lb = $self->{labels}->{$labelb};
131            
132 0         0 return $la->lessequal($lb);
133             } else {
134 0         0 return undef;
135             }
136             }
137              
138             sub greaterthan {
139 1     1 0 26 my ($self, $labela, $labelb) = @_;
140              
141 1 50 33     11 if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb} ) {
142 1         2 my $la = $self->{labels}->{$labela};
143 1         3 my $lb = $self->{labels}->{$labelb};
144            
145 1         4 return $la->greaterthan($lb);
146             } else {
147 0         0 return undef;
148             }
149             }
150             sub greaterequal {
151 0     0 0 0 my ($self, $labela, $labelb) = @_;
152              
153 0 0 0     0 if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb} ) {
154 0         0 my $la = $self->{labels}->{$labela};
155 0         0 my $lb = $self->{labels}->{$labelb};
156            
157 0         0 return $la->greaterequal($lb);
158             } else {
159 0         0 return undef;
160             }
161             }
162              
163             sub between {
164 2     2 0 52 my ($self, $labela, $labelb, $labelc) = @_;
165              
166 2 50 33     25 if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb}
      33        
167             and exists $self->{labels}->{$labelc} ) {
168 2         4 my $la = $self->{labels}->{$labela};
169 2         29 my $lb = $self->{labels}->{$labelb};
170 2         4 my $lc = $self->{labels}->{$labelc};
171            
172 2         8 return $la->between($lb, $lc);
173             } else {
174 0           return undef;
175             }
176             }
177             1;