File Coverage

blib/lib/Lingua/YaTeA/MultiWordTermCandidate.pm
Criterion Covered Total %
statement 101 243 41.5
branch 16 48 33.3
condition 7 9 77.7
subroutine 24 30 80.0
pod 23 23 100.0
total 171 353 48.4


line stmt bran cond sub pod time code
1             package Lingua::YaTeA::MultiWordTermCandidate;
2 5     5   28 use strict;
  5         8  
  5         117  
3 5     5   22 use warnings;
  5         8  
  5         97  
4 5     5   1759 use Lingua::YaTeA::TermCandidate;
  5         11  
  5         46  
5 5     5   1955 use Lingua::YaTeA::IndexSet;
  5         11  
  5         48  
6 5     5   128 use Data::Dumper;
  5         8  
  5         195  
7              
8 5     5   25 use UNIVERSAL;
  5         6  
  5         15  
9 5     5   107 use Scalar::Util qw(blessed);
  5         8  
  5         9458  
10              
11             our @ISA = qw(Lingua::YaTeA::TermCandidate);
12             our $VERSION=$Lingua::YaTeA::VERSION;
13              
14             sub new
15             {
16 118     118 1 174 my ($class) = @_;
17 118         237 my $this = $class->SUPER::new;
18            
19 118         186 $this->{ROOT_HEAD} = ();
20 118         161 $this->{ROOT_MODIFIER} = ();
21 118         153 $this->{PREPOSITION} = ();
22 118         198 $this->{DETERMINER} = ();
23 118         208 $this->{MODIFIER_POSITION} = ();
24 118         265 $this->{INDEX_SET} = Lingua::YaTeA::IndexSet->new;
25 118         233 $this->{ISLANDS} = [];
26 118         163 $this->{ISLAND_TYPE} = ();
27 118         164 bless ($this,$class);
28 118         206 return $this;
29             }
30              
31             sub getRootHead
32             {
33 782     782 1 1095 my ($this) = @_;
34 782         1760 return $this->{ROOT_HEAD};
35             }
36              
37             sub getIslandType
38             {
39 11     11 1 21 my ($this) = @_;
40 11         25 return $this->{ISLAND_TYPE};
41             }
42              
43             sub getPreposition
44             {
45 138     138 1 184 my ($this) = @_;
46 138         284 return $this->{PREPOSITION};
47             }
48              
49             sub getDeterminer
50             {
51 118     118 1 170 my ($this) = @_;
52 118         239 return $this->{DETERMINER};
53             }
54              
55             sub getRootModifier
56             {
57 356     356 1 483 my ($this) = @_;
58 356         664 return $this->{ROOT_MODIFIER};
59             }
60              
61             sub getModifierPosition
62             {
63 112     112 1 169 my ($this) = @_;
64 112         221 return $this->{MODIFIER_POSITION};
65             }
66              
67             sub searchHead
68             {
69 142     142 1 198 my ($this, $depth) = @_;
70 142         159 my $head;
71              
72 142         167 $depth++;
73              
74             # warn "REF: " . ref($this->getRootHead) . "\n";
75             # warn "BLESSED: " . blessed($this->getRootHead) . "\n";
76 142 100 66     205 if ((blessed($this->getRootHead)) && ($this->getRootHead->isa('Lingua::YaTeA::MonolexicalTermCandidate')))
77             {
78 112         173 $head = $this->getRootHead;
79             }
80             else
81             {
82 30 50       61 if ($depth < 40) {
83 30         44 $head = $this->getRootHead->searchHead ($depth);
84             }
85             }
86 142         265 return $head;
87             }
88              
89             sub setOccurrences
90             {
91 118     118 1 187 my ($this,$phrase_occurrences_a,$offset,$maximal) = @_;
92 118         144 my $phrase_occurrence;
93              
94 118 100       206 if($maximal == 1)
95             {
96 70         109 $this->{OCCURRENCES} = $phrase_occurrences_a;
97 70         115 $this->{MNP_STATUS} = 1;
98             }
99             else
100             {
101 48         103 foreach $phrase_occurrence (@$phrase_occurrences_a)
102             {
103 48         114 my $occurrence = Lingua::YaTeA::Occurrence->new;
104 48         89 $occurrence->{SENTENCE} = $phrase_occurrence->getSentence;
105 48         89 $occurrence->{START_CHAR} = $phrase_occurrence->getStartChar + $offset;
106 48         66 $occurrence->{MAXIMAL} = 0;
107 48         89 $this->addOccurrence($occurrence);
108             }
109             }
110             }
111              
112             sub completeOccurrences
113             {
114 118     118 1 176 my ($this,$offset) = @_;
115 118         140 my $occurrence;
116              
117             # print STDERR "---> " . $this->getID() . "\n";
118              
119 118         131 foreach $occurrence (@{$this->getOccurrences})
  118         221  
120             {
121             # print STDERR $occurrence->{ID} . "\n";
122             # print STDERR $occurrence->{START_CHAR} . "\n";
123              
124 126         243 $occurrence->{END_CHAR} = $occurrence->getStartChar + $offset - 1; # + $offset
125             # print STDERR $occurrence->{END_CHAR} . "\n";
126             }
127             }
128              
129             sub getIndexSet
130             {
131 363     363 1 524 my ($this) = @_;
132 363         684 return $this->{INDEX_SET};
133             }
134              
135             sub addIndexSet
136             {
137 48     48 1 67 my ($this,$index_set_to_add) = @_;
138 48         69 $this->getIndexSet->mergeWith($index_set_to_add);
139             }
140              
141              
142             sub setIslands
143             {
144 118     118 1 194 my ($this,$phrase_island_set,$left,$right) = @_;
145 118         133 my $island;
146            
147 118 100 66     332 if((defined $phrase_island_set)
148             &&
149             ($phrase_island_set->size != 0)
150             )
151             {
152 30         38 foreach $island (values (%{$phrase_island_set->getIslands}))
  30         52  
153             {
154 30 100       60 if($this->getIndexSet->contains($island->getIndexSet))
155             {
156             # islands are recorded
157 24 100 100     64 if
158             (
159             # if they are exogenous
160             ($island->getType ne 'endogenous' )
161             ||
162             # if they are endogenous and don't cover the full TC
163             ($this->getIndexSet->joinAll('-') ne $island->getIndexSet->joinAll('-'))
164             )
165             {
166 18         39 $this->addIsland($island);
167             }
168             }
169             }
170             }
171             }
172              
173             sub addIsland
174             {
175 18     18 1 24 my ($this,$island) = @_;
176            
177 18         21 push @{$this->getIslands}, $island;
  18         35  
178             }
179              
180             sub adjustIslandReferences
181             {
182 16     16 1 25 my ($this,$mapping_from_phrases_to_TCs_h) = @_;
183 16         19 my $island;
184             my $type;
185              
186 16         20 foreach $island (@{$this->getIslands})
  16         24  
187             {
188 16         32 $type = $island->getType;
189              
190 16 100       45 if
191             ($type eq 'endogenous')
192             {
193 11 50       25 if(exists $mapping_from_phrases_to_TCs_h->{$island->getSource->getID})
194             {
195            
196             # the island is no longer linked to a phrase: it is now linked to a term candidate
197 11         23 $island = $mapping_from_phrases_to_TCs_h->{$island->getSource->getID};
198             }
199             else
200             {
201 0         0 die "y a un blem\n";
202             }
203             }
204             else
205             {
206 5         8 $island = $island->getSource;
207             }
208 16         43 $island->{ISLAND_TYPE} = $type;
209             }
210             }
211              
212              
213              
214             sub getIslands
215             {
216 274     274 1 370 my ($this) = @_;
217 274         579 return $this->{ISLANDS};
218             }
219              
220              
221              
222             sub containsIslands
223             {
224 224     224 1 410 my ($this) = @_;
225 224 100       261 if(scalar @{$this->getIslands} > 0)
  224         315  
226             {
227 32         90 return 1;
228             }
229 192         479 return 0;
230             }
231              
232             sub getHeadAndLinks
233             {
234 0     0 1   my ($this,$LGPmapping_h,$chained_links) = @_;
235 0           my $phrase = $this->getOriginalPhrase;
236 0           my $head = $phrase->getWord($phrase->getTree(0)->getHead->getIndex);
237 0           my $left;
238             my $right;
239 0           my $prep;
240 0           my $det;
241 0           my $node;
242 0           my $link_key;
243 0           my @links;
244 0           my %first;
245 0           my %second;
246              
247            
248 0           foreach $node (@{$phrase->getTree(0)->getNodeSet->getNodes})
  0            
249             {
250 0           $left = $node->getLeftEdge->searchHead (0);
251 0           $right = $node->getRightEdge->searchHead (0);
252 0           $prep = $node->getPreposition;
253 0           $det = $node->getDeterminer;
254              
255 0 0         if (defined $prep)
256             {
257 0           $link_key = $left->getPOS($phrase->getWords) . "-" . $prep->getPOS($phrase->getWords);
258 0           $this->recordLink($link_key,$left,$prep,\@links,$LGPmapping_h);
259 0           push @{$first{$left->getIndex}}, $prep->getIndex;
  0            
260 0           push @{$second{$prep->getIndex}}, $left->getIndex;
  0            
261              
262 0           $link_key = $prep->getPOS($phrase->getWords) . "-" . $right->getPOS($phrase->getWords);
263 0           $this->recordLink($link_key,$prep,$right,\@links,$LGPmapping_h);
264 0           push @{$first{$prep->getIndex}}, $right->getIndex;
  0            
265 0           push @{$second{$right->getIndex}}, $prep->getIndex;
  0            
266             }
267             else
268             {
269 0           $link_key = $left->getPOS($phrase->getWords) . "-" . $right->getPOS($phrase->getWords);
270 0           $this->recordLink($link_key,$left,$right,\@links,$LGPmapping_h);
271 0           push @{$first{$left->getIndex}}, $right->getIndex;
  0            
272 0           push @{$second{$right->getIndex}}, $left->getIndex;
  0            
273             }
274              
275 0 0         if (defined $det)
276             {
277 0           $link_key = $det->getPOS($phrase->getWords) . "-" . $right->getPOS($phrase->getWords);
278 0           $this->recordLink($link_key,$det,$right,\@links,$LGPmapping_h);
279 0           push @{$first{$det->getIndex}}, $right->getIndex;
  0            
280 0           push @{$second{$right->getIndex}}, $det->getIndex;
  0            
281             }
282             }
283 0           $this->adjustLinksHeight(\@links,\%first,\%second);
284 0           @links = sort{$this->sortLinks($a,$b)} @links;
  0            
285 0 0         if($chained_links == 1)
286             {
287 0           $this->chainLinks(\@links);
288             }
289 0           return ($phrase->getWord($phrase->getTree(0)->getHead->getIndex),$phrase->getTree(0)->getHead->getIndex,\@links);
290             }
291              
292             sub chainLinks
293             {
294 0     0 1   my ($this,$links_a) = @_;
295 0           my $link;
296 0           my $links_sets_h = $this->getLinksSets($links_a);
297 0           my @chained_links;
298             my $set_a;
299 0           my $left;
300 0           my $right;
301 0           my $height;
302 0           my $type;
303 0           my $i;
304 0           my $search;
305 0           my %recorded;
306 0           my $updated_height;
307 0           my $previous_right;
308 0           foreach $set_a (values (%$links_sets_h))
309             {
310 0 0         if(scalar @$set_a > 1)
311             {
312 0           while ( $link = pop @$set_a)
313             {
314 0           $link =~ /\[([0-9]+) ([0-9]+) ([0-9]+) \(([^\)]+)\)\]/;
315 0           $left = $1;
316 0           $right = $2;
317 0           $height = $3;
318 0           $type = $4;
319 0 0         if($type eq "CH")
320             {
321 0 0         if($left < $right -1)
322             {
323 0           $updated_height = 0;
324 0           for ($i= $left+1; $i < $right; $i++)
325             {
326 0 0         if(!defined $previous_right)
327             {
328 0           $previous_right = $right;
329             }
330 0           $search = $i . " " . $previous_right ;
331            
332 0 0         if(exists $recorded{$search})
333             {
334 0           $right = $i;
335 0           $height = $updated_height;
336 0           last;
337             }
338             else
339             {
340 0           $updated_height++;
341             }
342             }
343             }
344 0           $recorded{$left . " " . $right}++;
345 0           $previous_right = $right;
346 0           $link = "[". $left . " " . $right . " " . $height . " (" . $type . ")]";
347             }
348 0           push @chained_links, $link;
349             }
350             }
351             else
352             {
353 0           push @chained_links, @$set_a;
354             }
355             }
356 0           @$links_a = sort{$this->sortLinks($a,$b)} @chained_links;
  0            
357             }
358              
359             sub getLinksSets
360             {
361 0     0 1   my ($this,$links_a) = @_;
362 0           my %sets;
363             my $link;
364 0           foreach $link (@$links_a){
365 0           $link =~ /\[([0-9]+) ([0-9]+) ([0-9]+) (\([^\)]+\)\])/;
366 0           push @{$sets{$2}}, $link;
  0            
367             }
368 0           return \%sets;
369             }
370              
371              
372             sub sortLinks
373             {
374 0     0 1   my ($this,$link1,$link2) = @_;
375 0           my $first_element_of_link1;
376             my $second_element_of_link1;
377 0           my $first_element_of_link2;
378 0           my $second_element_of_link2;
379              
380 0           $link1 =~ /\[([0-9]+) ([0-9]+) ([0-9]+) (\([^\)]+\)\])/;
381 0           $first_element_of_link1 = $1;
382 0           $second_element_of_link1 = $2;
383 0           $link2 =~ /\[([0-9]+) ([0-9]+) ([0-9]+) (\([^\)]+\)\])/;
384 0           $first_element_of_link2 = $1;
385 0           $second_element_of_link2 = $2;
386              
387 0 0         if ($first_element_of_link1 != $first_element_of_link2){
388 0           return ($first_element_of_link1 <=> $first_element_of_link2);
389             }
390 0           return ($second_element_of_link1 <=> $second_element_of_link2);
391             }
392              
393             sub adjustLinksHeight
394             {
395 0     0 1   my ($this,$links_a,$first_h,$second_h) = @_;
396 0           my $link;
397             my $first_word;
398 0           my $second_word;
399 0           my $link_tag;
400 0           my $height;
401 0           my $first_word_of_other_link;
402 0           my $second_word_of_other_link;
403              
404 0 0         if(scalar @$links_a > 1)
405             {
406 0           foreach $link (@$links_a){
407 0           $link =~ /\[([0-9]+) ([0-9]+) ([0-9]+) (\([^\)]+\)\])/;
408 0           $first_word = $1;
409 0           $second_word = $2;
410 0           $height = $3;
411 0           $link_tag = $4;
412 0 0         if(exists $first_h->{$first_word}){
413 0           foreach $second_word_of_other_link (@{$first_h->{$first_word}}){
  0            
414 0 0         if($second_word_of_other_link < $second_word){
415 0           $height++;
416             }
417             }
418             }
419 0 0         if(exists $second_h->{$second_word}){
420 0           foreach $first_word_of_other_link (@{$second_h->{$second_word}}){
  0            
421 0 0         if($first_word_of_other_link > $first_word){
422 0           $height++;
423             }
424             }
425             }
426 0           $link = "[".$first_word . " " . $second_word . " " .$height . " " . $link_tag;
427             }
428             }
429             }
430              
431             sub recordLink
432             {
433 0     0 1   my ($this,$link_key,$first_element,$second_element,$links_a,$LGPmapping_h) = @_;
434 0           my $LGP_link;
435             my %first_items;
436 0           my %second_items;
437            
438 0 0         if(exists $LGPmapping_h->{$link_key}){
439 0           $LGP_link = "[" .$first_element->getIndex . " " . $second_element->getIndex . " 0 (" .$LGPmapping_h->{$link_key} . ")]";
440 0           push @$links_a, $LGP_link;
441             }
442             else{
443 0           warn "Pas de mapping pour " . $link_key . " (" .$this->getIF . ")\n";
444             }
445             }
446              
447              
448             1;
449              
450             __END__