File Coverage

blib/lib/NNexus/Concepts.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             # /=====================================================================\ #
2             # | NNexus Autolinker | #
3             # | Concept Manipulation and Lookup Module | #
4             # |=====================================================================| #
5             # | Part of the Planetary project: http://trac.mathweb.org/planetary | #
6             # | Research software, produced as part of work done by: | #
7             # | the KWARC group at Jacobs University | #
8             # | Copyright (c) 2012 | #
9             # | Released under the MIT License (MIT) | #
10             # |---------------------------------------------------------------------| #
11             # | Adapted from the original NNexus code by | #
12             # | James Gardner and Aaron Krowne | #
13             # |---------------------------------------------------------------------| #
14             # | Deyan Ginev #_# | #
15             # | http://kwarc.info/people/dginev (o o) | #
16             # \=========================================================ooo==U==ooo=/ #
17             package NNexus::Concepts;
18 7     7   22095 use strict;
  7         12  
  7         275  
19 7     7   33 use warnings;
  7         7  
  7         327  
20              
21 7     7   607 use NNexus::Morphology qw(is_possessive is_plural normalize_word);
  7         9  
  7         491  
22 7     7   40 use Encode qw( is_utf8 );
  7         9  
  7         291  
23 7     7   31 use Exporter;
  7         9  
  7         251  
24 7     7   7663 use List::MoreUtils qw(uniq);
  0            
  0            
25              
26             our @ISA = qw(Exporter);
27             our @EXPORT_OK = qw(flatten_concept_harvest diff_concept_harvests clone_concepts links_from_concept);
28              
29             sub flatten_concept_harvest {
30             my ($indexed_concepts) = @_;
31             my $new_concepts=[];
32             foreach my $c(@$indexed_concepts) {
33             my $synonyms = delete $c->{synonyms}||[];
34             my $categories = delete $c->{categories}||[];
35             my @all_names = (@$synonyms, $c->{concept});
36             # Extend to normalized names:
37             @all_names = map {
38             join(' ', grep {$_} map { normalize_word($_) } split(/\s+/,$_))
39             } @all_names;
40             # In case some of the synonyms were misguidedly normalizing, let's get the unique elements:
41             @all_names = uniq(@all_names);
42             # Flatten names
43             my @synset = map {my %syn = %$c; $syn{concept}=$_; \%syn;} @all_names;
44             # Flatten categories
45             my @catset;
46             foreach my $sync (@synset) {
47             push @catset, map {my %cat = %$sync; $cat{category}=$_; \%cat;} @$categories;
48             }
49             push @$new_concepts, @catset;
50             }
51             return $new_concepts;
52             }
53              
54             sub diff_concept_harvests {
55             my ($old_concepts,$new_concepts) = @_;
56             my $delete_concepts=[];
57             my $add_concepts = [@$new_concepts];
58             while (@$old_concepts) {
59             my $c = shift @$old_concepts;
60             my $cname = $c->{concept};
61             my $ccat = $c->{category};
62             my @filtered_new = grep {($_->{concept} ne $cname) ||
63             ($_->{category} ne $ccat)} @$add_concepts;
64             if (scalar(@filtered_new) == scalar(@$add_concepts)) {
65             # Not found, delete $c
66             push @$delete_concepts, $c;
67             } else {
68             # Found, next
69             $add_concepts = \@filtered_new;
70             }
71             }
72             return ($delete_concepts,$add_concepts);
73             }
74              
75             sub clone_concepts {
76             my ($concepts) = @_;
77             # Shallow clone suffices
78             [map { {%$_} } @$concepts];
79             }
80              
81             sub links_from_concept {
82             my ($concept) = @_;
83             my @links = ();
84             @links = ($concept->{link}) if $concept->{link};
85             # Also include multilinks, if any:
86             if ($concept->{multilinks}) {
87             my @multi = @{$concept->{multilinks}};
88             while (@multi) {
89             my $next_link = shift @multi;
90             next if (grep {$_ eq $next_link} @links);
91             push @links, $next_link;
92             }
93             }
94             return @links; }
95              
96             1;
97              
98             __END__