File Coverage

blib/lib/OBO/Core/Ontology.pm
Criterion Covered Total %
statement 1768 2259 78.2
branch 482 812 59.3
condition 104 185 56.2
subroutine 138 147 93.8
pod 94 95 98.9
total 2586 3498 73.9


line stmt bran cond sub pod time code
1             # $Id: Ontology.pm 2014-11-14 erick.antezana $
2             #
3             # Module : Ontology.pm
4             # Purpose : OBO ontologies handling.
5             # License : Copyright (c) 2006-2014 by Erick Antezana. All rights reserved.
6             # This program is free software; you can redistribute it and/or
7             # modify it under the same terms as Perl itself.
8             # Contact : Erick Antezana
9             #
10             package OBO::Core::Ontology;
11              
12 7     7   14356 use OBO::Core::IDspace;
  7         13  
  7         207  
13 7     7   2815 use OBO::Util::IDspaceSet;
  7         11  
  7         162  
14 7     7   2398 use OBO::Util::SubsetDefMap;
  7         13  
  7         155  
15 7     7   2388 use OBO::Util::SynonymTypeDefSet;
  7         12  
  7         177  
16 7     7   2457 use OBO::Util::TermSet;
  7         13  
  7         152  
17 7     7   1972 use OBO::Util::InstanceSet;
  7         10  
  7         152  
18 7     7   2431 use OBO::Util::RelationshipTypeSet;
  7         10  
  7         181  
19              
20 7     7   36 use Carp;
  7         8  
  7         350  
21 7     7   32 use strict;
  7         8  
  7         165  
22 7     7   30 use warnings;
  7         10  
  7         179  
23              
24 7     7   2742 use open qw(:std :utf8); # Make All I/O Default to UTF-8
  7         5744  
  7         30  
25              
26             our $VERSION = '1.44';
27              
28             sub new {
29 37     37 0 202 my $class = shift;
30 37         58 my $self = {};
31            
32 37         76 $self->{ID} = undef; # not required, (1)
33 37         150 $self->{NAME} = undef; # not required, (0..1)
34 37         118 $self->{IMPORTS} = OBO::Util::Set->new(); # set (0..N)
35 37         88 $self->{TREAT_XREFS_AS_EQUIVALENT} = OBO::Util::Set->new(); # set (0..N)
36 37         85 $self->{TREAT_XREFS_AS_IS_A} = OBO::Util::Set->new(); # set (0..N)
37 37         99 $self->{IDSPACES_SET} = OBO::Util::IDspaceSet->new(); # string (0..N)
38 37         64 $self->{DEFAULT_RELATIONSHIP_ID_PREFIX} = undef; # string (0..1)
39 37         85 $self->{DEFAULT_NAMESPACE} = undef; # string (0..1)
40 37         56 $self->{DATA_VERSION} = undef; # string (0..1)
41 37         52 $self->{DATE} = undef; # (1) The current date in dd:MM:yyyy HH:mm format
42 37         54 $self->{SAVED_BY} = undef; # string (0..1)
43 37         154 $self->{REMARKS} = OBO::Util::Set->new(); # set (0..N)
44 37         132 $self->{SUBSETDEF_MAP} = OBO::Util::SubsetDefMap->new(); # map of SubsetDef's (0..N); A subset is a view over an ontology
45 37         117 $self->{SYNONYM_TYPE_DEF_SET} = OBO::Util::SynonymTypeDefSet->new(); # set (0..N); A description of a user-defined synonym type
46              
47 37         68 $self->{TERMS} = {}; # map: term_id(string) vs. term(OBO::Core::Term) (0..N)
48 37         108 $self->{INSTANCES} = {}; # map: instance_id(string) vs. instance(OBO::Core::Instance) (0..N)
49 37         63 $self->{RELATIONSHIP_TYPES} = {}; # map: relationship_type_id(string) vs. relationship_type(OBO::Core::RelationshipType) (0..N)
50 37         59 $self->{RELATIONSHIPS} = {}; # (0..N)
51            
52 37         144 $self->{TERMS_SET} = OBO::Util::TermSet->new(); # Terms (0..n) # TODO Test this more deeply
53             #$self->{INSTANCES_SET} = OBO::Util::TermSet->new(); # Instances (0..n) # TODO enable the instances_set
54             #$self->{RELATIONSHIP_SET} = OBO::Util::RelationshipSet->new(); # TODO Implement RELATIONSHIP_SET
55            
56 37         59 $self->{TARGET_RELATIONSHIPS} = {}; # (0..N)
57 37         54 $self->{SOURCE_RELATIONSHIPS} = {}; # (0..N)
58 37         91 $self->{TARGET_SOURCE_RELATIONSHIPS} = {}; # (0..N)
59            
60 37         103 bless ($self, $class);
61 37         70 return $self;
62             }
63              
64             =head2 id
65              
66             Usage - print $ontology->id() or $ontology->id($id)
67             Returns - the ID space of this ontology (string)
68             Args - the ID space of this ontology (string)
69             Function - gets/sets the ID space of this ontology
70            
71             =cut
72              
73             sub id {
74 40     40 1 61 my ($self, $id) = @_;
75 40 100       87 if ($id) { $self->{ID} = $id }
  2         4  
76 40         106 return $self->{ID};
77             }
78              
79             =head2 name
80              
81             Usage - print $ontology->name() or $ontology->name($name)
82             Returns - the name (string) of the ontology
83             Args - the name (string) of the ontology
84             Function - gets/sets the name of the ontology
85            
86             =cut
87              
88             sub name {
89 0     0 1 0 my ($self, $name) = @_;
90 0 0       0 if ($name) { $self->{NAME} = $name }
  0         0  
91 0         0 return $self->{NAME};
92             }
93              
94             =head2 imports
95              
96             Usage - $onto->imports() or $onto->imports($id1, $id2, $id3, ...)
97             Returns - a set (OBO::Util::Set) with the imported id ontologies
98             Args - the ontology id(s) (string)
99             Function - gets/sets the id(s) of the ontologies that are imported by this one
100            
101             =cut
102              
103             sub imports {
104 29     29 1 43 my $self = shift;
105 29 100       129 if (scalar(@_) > 1) {
    100          
106 1         6 $self->{IMPORTS}->add_all(@_);
107             } elsif (scalar(@_) == 1) {
108 1         3 $self->{IMPORTS}->add($_[0]);
109             }
110 29         97 return $self->{IMPORTS};
111             }
112              
113             =head2 treat_xrefs_as_equivalent
114              
115             Usage - $onto->treat_xrefs_as_equivalent() or $onto->treat_xrefs_as_equivalent($xref1, $xref2, $xref3, ...)
116             Returns - a set (OBO::Util::Set) of ontology id spaces
117             Args - an ontology ID space(s) (string)
118             Function - gets/sets the id spaces(s) of the ontologies that their xrefs are treated as equivalent
119             Remark - Macro. Treats all xrefs coming from a particular ID-Space as being statements of exact equivalence.
120            
121             =cut
122              
123             sub treat_xrefs_as_equivalent {
124 62     62 1 77 my $self = shift;
125 62 100       214 if (scalar(@_) > 1) {
    50          
126 1         3 $self->{TREAT_XREFS_AS_EQUIVALENT}->add_all(@_);
127             } elsif (scalar(@_) == 1) {
128 0         0 $self->{TREAT_XREFS_AS_EQUIVALENT}->add($_[0]);
129             }
130 62         164 return $self->{TREAT_XREFS_AS_EQUIVALENT};
131             }
132              
133             =head2 treat_xrefs_as_is_a
134              
135             Usage - $onto->treat_xrefs_as_is_a() or $onto->treat_xrefs_as_is_a($xref1, $xref2, $xref3, ...)
136             Returns - a set (OBO::Util::Set) of ontology id spaces
137             Args - an ontology ID space(s) (string)
138             Function - gets/sets the id spaces(s) of the ontologies that their xrefs are treated as equivalent
139             Remark - Treats all xrefs coming from a particular ID-Space as being is_a relationships.
140            
141             =cut
142              
143             sub treat_xrefs_as_is_a {
144 62     62 1 163 my $self = shift;
145 62 100       191 if (scalar(@_) > 1) {
    50          
146 1         2 $self->{TREAT_XREFS_AS_IS_A}->add_all(@_);
147             } elsif (scalar(@_) == 1) {
148 0         0 $self->{TREAT_XREFS_AS_IS_A}->add($_[0]);
149             }
150 62         155 return $self->{TREAT_XREFS_AS_IS_A};
151             }
152              
153             =head2 date
154              
155             Usage - print $ontology->date()
156             Returns - the current date (in dd:MM:yyyy HH:mm format) of the ontology
157             Args - the current date (in dd:MM:yyyy HH:mm format) of the ontology
158             Function - gets/sets the date of the ontology
159             Remark - for historic reasons, this is NOT a ISO 8601 date, as is the case for the creation-date field
160            
161             =cut
162              
163             sub date {
164 32     32 1 48 my ($self, $d) = @_;
165 32 100       77 if ($d) { $self->{DATE} = $d }
  10         23  
166 32         114 return $self->{DATE};
167             }
168              
169             =head2 default_relationship_id_prefix
170              
171             Usage - print $ontology->default_relationship_id_prefix() or $ontology->default_relationship_id_prefix("OBO_REL")
172             Returns - the default relationship ID prefix (string) of this ontology
173             Args - the default relationship ID prefix (string) of this ontology
174             Function - gets/sets the default relationship ID prefix of this ontology
175             Remark - Any relationship lacking an ID space will be prefixed with the value of this tag.
176              
177             =cut
178              
179             sub default_relationship_id_prefix {
180 48     48 1 67 my ($self, $drip) = @_;
181 48 100       95 if ($drip) { $self->{DEFAULT_RELATIONSHIP_ID_PREFIX} = $drip }
  1         2  
182 48         87 return $self->{DEFAULT_RELATIONSHIP_ID_PREFIX};
183             }
184              
185             =head2 default_namespace
186              
187             Usage - print $ontology->default_namespace() or $ontology->default_namespace("cellcycle_ontology")
188             Returns - the default namespace (string) of this ontology
189             Args - the default namespace (string) of this ontology
190             Function - gets/sets the default namespace of this ontology
191            
192             =cut
193              
194             sub default_namespace {
195 58     58 1 71 my ($self, $dns) = @_;
196 58 100       125 if ($dns) { $self->{DEFAULT_NAMESPACE} = $dns }
  12         28  
197 58         118 return $self->{DEFAULT_NAMESPACE};
198             }
199              
200             =head2 idspaces
201              
202             Usage - $ontology->idspaces() or $ontology->idspaces($IDspace)
203             Returns - the id spaces, as a set (OBO::Util::IDspaceSet) of OBO::Core::IDspace's, of this ontology
204             Args - the id spaces, as a set (OBO::Util::IDspaceSet) of OBO::Core::IDspace's, of this ontology
205             Function - gets/sets the idspaces of this ontology
206            
207             =cut
208              
209             sub idspaces {
210 86     86 1 100 my $self = shift;
211 86 100       258 if (scalar(@_) > 1) {
    100          
212 5         18 $self->{IDSPACES_SET}->add_all(@_);
213             } elsif (scalar(@_) == 1) {
214 8         31 $self->{IDSPACES_SET}->add($_[0]);
215             }
216 86         210 return $self->{IDSPACES_SET};
217             }
218              
219             =head2 data_version
220              
221             Usage - print $ontology->data_version()
222             Returns - the data version (string) of this ontology
223             Args - the data version (string) of this ontology
224             Function - gets/sets the data version of this ontology
225            
226             =cut
227              
228             sub data_version {
229 21     21 1 36 my ($self, $dv) = @_;
230 21 100       55 if ($dv) { $self->{DATA_VERSION} = $dv }
  2         7  
231 21         64 return $self->{DATA_VERSION};
232             }
233              
234             =head2 saved_by
235              
236             Usage - print $ontology->saved_by()
237             Returns - the username of the person (string) to last save this ontology
238             Args - the username of the person (string) to last save this ontology
239             Function - gets/sets the username of the person to last save this ontology
240            
241             =cut
242              
243             sub saved_by {
244 35     35 1 60 my ($self, $sb) = @_;
245 35 100       86 if ($sb) { $self->{SAVED_BY} = $sb }
  21         40  
246 35         81 return $self->{SAVED_BY};
247             }
248              
249             =head2 remarks
250              
251             Usage - print $ontology->remarks()
252             Returns - the remarks (OBO::Util::Set) of this ontology
253             Args - the remarks (OBO::Util::Set) of this ontology
254             Function - gets/sets the remarks of this ontology
255            
256             =cut
257              
258             sub remarks {
259 57     57 1 107 my $self = shift;
260 57 100       205 if (scalar(@_) > 1) {
    100          
261 1         4 $self->{REMARKS}->add_all(@_);
262             } elsif (scalar(@_) == 1) {
263 21         60 $self->{REMARKS}->add($_[0]);
264             }
265 57         136 return $self->{REMARKS};
266             }
267              
268             =head2 subset_def_map
269              
270             Usage - $onto->subset_def_map() or $onto->subset_def_map($subset_def_map)
271             Returns - a map (OBO::Util::SubsetDefMap) with the subset definition(s) used in this ontology. A subset is a view over an ontology
272             Args - a subset definitions map (OBO::Core::SubsetDefMap)
273             Function - gets/sets the subset definition(s) of this ontology
274            
275             =cut
276              
277             sub subset_def_map {
278 154     154 1 489 my $self = shift;
279 154         501 $self->{SUBSETDEF_MAP}->put_all(@_);
280 154         493 return $self->{SUBSETDEF_MAP};
281             }
282              
283             =head2 synonym_type_def_set
284              
285             Usage - $onto->synonym_type_def_set() or $onto->synonym_type_def_set($st1, $st2, $st3, ...)
286             Returns - a set (OBO::Util::SynonymTypeDefSet) with the synonym type definitions used in this ontology. A synonym type is a description of a user-defined synonym type
287             Args - the synonym type definition(s) (OBO::Core::SynonymTypeDef) used in this ontology
288             Function - gets/sets the synonym type definitions (s) of this ontology
289            
290             =cut
291              
292             sub synonym_type_def_set {
293 61     61 1 139 my $self = shift;
294 61 100       203 if (scalar(@_) > 1) {
    100          
295 6         26 $self->{SYNONYM_TYPE_DEF_SET}->add_all(@_);
296             } elsif (scalar(@_) == 1) {
297 1         4 $self->{SYNONYM_TYPE_DEF_SET}->add($_[0]);
298             }
299 61         183 return $self->{SYNONYM_TYPE_DEF_SET};
300             }
301              
302             =head2 add_term
303              
304             Usage - $ontology->add_term($term)
305             Returns - the just added term (OBO::Core::Term)
306             Args - the term (OBO::Core::Term) to be added. The ID of the term to be added must have already been defined.
307             Function - adds a term to this ontology
308             Remark - adding a term to an ontology does not mean adding its instances
309            
310             =cut
311              
312             sub add_term {
313 2293     2293 1 2185 my ($self, $term) = @_;
314 2293 50       3534 if ($term) {
315 2293         3376 my $term_id = $term->id();
316 2293 50       3184 if ($term_id) {
317 2293         5238 $self->{TERMS}->{$term_id} = $term;
318 2293         4995 $self->{TERMS_SET}->add($term);
319 2293         3507 return $term;
320             } else {
321 0         0 croak 'A term to be added to this ontology must have an ID.';
322             }
323             } else {
324 0         0 croak 'Missing term.';
325             }
326             }
327              
328             =head2 add_instance
329              
330             Usage - $ontology->add_instance($instance)
331             Returns - the just added instance (OBO::Core::Instance)
332             Args - the instance (OBO::Core::Instance) to be added. The ID of the instance to be added must have already been defined.
333             Function - adds a instance to this ontology
334            
335             =cut
336              
337             sub add_instance {
338 18     18 1 24 my ($self, $instance) = @_;
339 18 50       32 if ($instance) {
340 18         36 my $instance_id = $instance->id();
341 18 50       33 if (defined $instance_id) {
342 18         40 $self->{INSTANCES}->{$instance_id} = $instance;
343             #$self->{INSTANCES_SET}->add($instance);
344 18         33 return $instance;
345             } else {
346 0         0 croak 'A instance to be added to this ontology must have an ID.';
347             }
348             } else {
349 0         0 croak 'Missing instance.';
350             }
351             }
352              
353             =head2 add_term_as_string
354              
355             Usage - $ontology->add_term_as_string($term_id, $term_name)
356             Returns - the just added term (OBO::Core::Term)
357             Args - the term id (string) and the term name (string) of term to be added
358             Function - adds a term to this ontology
359            
360             =cut
361              
362             sub add_term_as_string {
363 1     1 1 2 my $self = shift;
364 1 50       2 if (@_) {
365 1         2 my $term_id = shift;
366 1 50       3 if (!$self->has_term_id($term_id)){
367 1         1 my $term_name = shift;
368 1 50       3 $term_id || croak 'A term to be added to this ontology must have an ID.';
369 1         3 my $new_term = OBO::Core::Term->new();
370 1         3 $new_term->id($term_id);
371 1         2 $new_term->name($term_name);
372 1         2 $self->add_term($new_term);
373 1         2 return $new_term;
374             } else {
375 0         0 warn "The term you tried to add ($term_id) is already in the ontology.\n";
376             }
377             } else {
378 0         0 croak 'To add a term, you need to provide both a term ID and a term name.';
379             }
380             }
381              
382             =head2 add_instance_as_string
383              
384             Usage - $ontology->add_instance_as_string($instance_id, $instance_name)
385             Returns - the just added instance (OBO::Core::Instance)
386             Args - the instance id (string) and the instance name (string) of instance to be added
387             Function - adds a instance to this ontology
388            
389             =cut
390              
391             sub add_instance_as_string {
392 1     1 1 1 my $self = shift;
393 1 50       3 if (@_) {
394 1         2 my $instance_id = shift;
395 1 50       3 if (!$self->has_instance_id($instance_id)){
396 1         2 my $instance_name = shift;
397 1 50       3 $instance_id || croak 'A instance to be added to this ontology must have an ID.';
398 1         6 my $new_instance = OBO::Core::Instance->new();
399 1         3 $new_instance->id($instance_id);
400 1         3 $new_instance->name($instance_name);
401 1         3 $self->add_instance($new_instance);
402 1         2 return $new_instance;
403             } else {
404 0         0 warn "The instance you tried to add ($instance_id) is already in the ontology.\n";
405             }
406             } else {
407 0         0 croak 'To add a instance, you need to provide both a instance ID and a instance name.';
408             }
409             }
410              
411             =head2 add_relationship_type
412              
413             Usage - $ontology->add_relationship_type($relationship_type)
414             Returns - the just added relationship type (OBO::Core::RelationshipType)
415             Args - the relationship type to be added (OBO::Core::RelationshipType). The ID of the relationship type to be added must have already been defined.
416             Function - adds a relationship type to this ontology
417            
418             =cut
419              
420             sub add_relationship_type {
421 142     142 1 165 my ($self, $relationship_type) = @_;
422 142 50       237 if ($relationship_type) {
423 142         304 $self->{RELATIONSHIP_TYPES}->{$relationship_type->id()} = $relationship_type;
424 142         296 return $relationship_type;
425            
426             # TODO Is it necessary to implement a set of relationship types? Maybe for get_relationship_types()?
427             #$self->{RELATIONSHIP_TYPES_SET}->add($relationship_type);
428             } else {
429 0         0 croak 'Missing argument: add_relationship_type(relationship_type)';
430             }
431             }
432              
433             =head2 add_relationship_type_as_string
434              
435             Usage - $ontology->add_relationship_type_as_string($relationship_type_id, $relationship_type_name)
436             Returns - the just added relationship type (OBO::Core::RelationshipType)
437             Args - the relationship type id (string) and the relationship type name (string) of the relationship type to be added
438             Function - adds a relationship type to this ontology
439            
440             =cut
441              
442             sub add_relationship_type_as_string {
443 27     27 1 107 my $self = shift;
444 27 50       55 if (@_) {
445 27         31 my $relationship_type_id = shift;
446            
447 27 50       45 $relationship_type_id || croak 'A relationship type to be added to this ontology must have an ID';
448            
449 27 50       48 if (!$self->has_relationship_type_id($relationship_type_id)){
450 27         29 my $relationship_type_name = shift;
451 27         155 my $new_relationship_type = OBO::Core::RelationshipType->new();
452 27         55 $new_relationship_type->id($relationship_type_id);
453 27         55 $new_relationship_type->name($relationship_type_name);
454 27         50 $self->add_relationship_type($new_relationship_type);
455 27         46 return $new_relationship_type;
456             } else {
457 0         0 warn "The relationship type you tried to add ($relationship_type_id) is already in the ontology\n";
458             }
459             } else {
460 0         0 croak 'To add a relationship type, you need to provide both a relationship type ID and a relationship type name';
461             }
462             }
463              
464             =head2 delete_term
465              
466             Usage - $ontology->delete_term($term)
467             Returns - none
468             Args - the term (OBO::Core::Term) to be deleted
469             Function - deletes a term from this ontology
470             Remark - the resulting ontology might be segmented, i.e., the deleted node might create an unconnected sub-ontology
471             Remark - the term (OBO::Core::Term) still exits after removing it from this ontology
472            
473             =cut
474              
475             sub delete_term {
476 5     5 1 13 my ($self, $term) = @_;
477 5 50       10 if ($term) {
478 5 50       11 $term->id() || croak 'The term to be deleted from this ontology does not have an ID.';
479            
480 5         9 my $id = $term->id();
481 5 100 66     26 if (defined($id) && defined($self->{TERMS}->{$id})) {
482 3         6 delete $self->{TERMS}->{$id};
483 3         13 $self->{TERMS_SET}->remove($term);
484            
485             # Delete the relationships: to its parents and children!
486 3         3 my @outward = @{$self->get_relationships_by_source_term($term)};
  3         8  
487 3         4 my @inward = @{$self->get_relationships_by_target_term($term)};
  3         7  
488 3         7 foreach my $r (@outward, @inward){
489 3         5 $self->delete_relationship($r);
490             }
491             }
492             }
493             }
494              
495             =head2 delete_instance
496              
497             Usage - $ontology->delete_instance($instance)
498             Returns - none
499             Args - the instance (OBO::Core::Instance) to be deleted
500             Function - deletes a instance from this ontology
501             Remark - the instance (OBO::Core::Instance) still exits after removing it from this ontology
502            
503             =cut
504              
505             sub delete_instance {
506 2     2 1 3 my ($self, $instance) = @_;
507 2 50       4 if ($instance) {
508 2 50       5 $instance->id() || croak 'The instance to be deleted from this ontology does not have an ID.';
509            
510 2         3 my $id = $instance->id();
511 2 100 66     10 if (defined($id) && defined($self->{INSTANCES}->{$id})) {
512 1         3 delete $self->{INSTANCES}->{$id};
513             #$self->{INSTANCES_SET}->remove($instance);
514            
515             # TODO Delete the relationships ($self->delete_relationship()): to its parents and children!
516             }
517             }
518             }
519              
520             =head2 delete_relationship
521              
522             Usage - $ontology->delete_relationship($rel)
523             Returns - none
524             Args - the relationship (OBO::Core::Relationship) to be deleted
525             Function - deletes a relationship from this ontology
526             Remark - the relationship (OBO::Core::Relationship) still exits after removing it from this ontology
527              
528             =cut
529              
530             sub delete_relationship {
531 56     56 1 61 my ($self, $relationship) = @_;
532 56 50       129 if ($relationship) {
533 56 50       118 $relationship->id() || croak 'The relationship to be deleted from this ontology does not have an ID.';
534            
535 56         135 my $id = $relationship->id();
536 56 50 33     232 if (defined($id) && defined($self->{RELATIONSHIPS}->{$id})) {
537 56         93 delete $self->{RELATIONSHIPS}->{$id};
538            
539 56         96 my $head = $relationship->head();
540 56         97 my $type = $relationship->type();
541 56         96 my $tail = $relationship->tail();
542 56         157 delete $self->{TARGET_RELATIONSHIPS}->{$head}->{$type}->{$tail};
543 56         107 delete $self->{SOURCE_RELATIONSHIPS}->{$tail}->{$type}->{$head};
544 56         230 delete $self->{TARGET_SOURCE_RELATIONSHIPS}->{$tail}->{$head}->{$type};
545              
546             #$self->{RELATIONSHIPS_SET}->remove($term);
547             }
548             }
549             }
550              
551             =head2 has_term
552              
553             Usage - print $ontology->has_term($term)
554             Returns - true or false
555             Args - the term (OBO::Core::Term) to be tested
556             Function - checks if the given term belongs to this ontology
557            
558             =cut
559              
560             sub has_term {
561 6822     6822 1 5427 my ($self, $term) = @_;
562             #return (defined $term && defined($self->{TERMS}->{$term->id()})); # TODO Is this faster than:
563 6822   100     17989 return defined $term && $self->{TERMS_SET}->contains($term);
564             }
565              
566             =head2 has_instance
567              
568             Usage - print $ontology->has_instance($instance)
569             Returns - true or false
570             Args - the instance (OBO::Core::Instance) to be tested
571             Function - checks if the given instance belongs to this ontology
572            
573             =cut
574              
575             sub has_instance {
576 21     21 1 41 my ($self, $instance) = @_;
577 21   66     72 return (defined $instance && defined($self->{INSTANCES}->{$instance->id()}));
578             # TODO Check the INSTANCES_SET
579             #$result = 1 if (defined($id) && defined($self->{INSTANCES}->{$id}) && $self->{INSTANCES_SET}->contains($instance));
580             }
581              
582             =head2 has_term_id
583              
584             Usage - print $ontology->has_term_id($term_id)
585             Returns - true or false
586             Args - the term id (string) to be tested
587             Function - checks if the given term id corresponds to a term held by this ontology
588            
589             =cut
590              
591             sub has_term_id {
592 10     10 1 18 my ($self, $term_id) = @_;
593 10   66     51 return (defined $term_id && defined($self->{TERMS}->{$term_id}));
594             # TODO Check the TERMS_SET
595             #return (defined $term_id && defined($self->{TERMS}->{$term_id}) && $self->{TERMS_SET}->contains($self->get_term_by_id($term_id)));
596             }
597              
598             =head2 has_instance_id
599              
600             Usage - print $ontology->has_instance_id($instance_id)
601             Returns - true or false
602             Args - the instance id (string) to be tested
603             Function - checks if the given instance id corresponds to a instance held by this ontology
604            
605             =cut
606              
607             sub has_instance_id {
608 9     9 1 12 my ($self, $instance_id) = @_;
609 9   66     45 return (defined $instance_id && defined($self->{INSTANCES}->{$instance_id}));
610             # TODO Check the INSTANCES_SET
611             #return (defined $instance_id && defined($self->{INSTANCES}->{$instance_id}) && $self->{INSTANCES_SET}->contains($self->get_instance_by_id($instance_id)));
612             }
613              
614             =head2 has_relationship_type
615              
616             Usage - print $ontology->has_relationship_type($relationship_type)
617             Returns - true or false
618             Args - the relationship type (OBO::Core::RelationshipType) to be tested
619             Function - checks if the given relationship type belongs to this ontology
620            
621             =cut
622              
623             sub has_relationship_type {
624 276     276 1 257 my ($self, $relationship_type) = @_;
625 276   66     829 return (defined $relationship_type && defined($self->{RELATIONSHIP_TYPES}->{$relationship_type->id()}));
626             }
627              
628             =head2 has_relationship_type_id
629              
630             Usage - print $ontology->has_relationship_type_id($relationship_type_id)
631             Returns - true or false
632             Args - the relationship type id (string) to be tested
633             Function - checks if the given relationship type id corresponds to a relationship type held by this ontology
634            
635             =cut
636              
637             sub has_relationship_type_id {
638 3538     3538 1 3468 my ($self, $relationship_type_id) = @_;
639 3538   66     14408 return (defined $relationship_type_id && defined($self->{RELATIONSHIP_TYPES}->{$relationship_type_id}));
640             }
641              
642             =head2 has_relationship_id
643              
644             Usage - print $ontology->has_relationship_id($rel_id)
645             Returns - true or false
646             Args - the relationship id (string) to be tested
647             Function - checks if the given relationship id corresponds to a relationship held by this ontology
648            
649             =cut
650              
651             sub has_relationship_id {
652 1441     1441 1 1700 my ($self, $id) = @_;
653 1441   66     7302 return (defined $id && defined($self->{RELATIONSHIPS}->{$id}));
654             }
655              
656             =head2 equals
657              
658             Usage - print $ontology->equals($another_ontology)
659             Returns - either 1 (true) or 0 (false)
660             Args - the ontology (OBO::Core::Ontology) to compare with
661             Function - tells whether this ontology is equal to the parameter
662            
663             =cut
664              
665             sub equals {
666 0     0 1 0 my $self = shift;
667 0         0 my $result = 0;
668            
669             # TODO Implement this method
670 0         0 croak 'Function: OBO::Core:Ontology::equals in not implemented yet, use OBO::Util::Ontolome meanwhile';
671            
672 0         0 return $result;
673             }
674              
675             =head2 get_terms
676              
677             Usage - $ontology->get_terms() or $ontology->get_terms("APO:I.*") or $ontology->get_terms("GO:012*")
678             Returns - the terms held by this ontology as a reference to an array of OBO::Core::Term's
679             Args - none or the regular expression for filtering the terms by id's
680             Function - returns the terms held by this ontology
681            
682             =cut
683              
684             sub get_terms {
685 94     94 1 164 my $self = shift;
686 94         93 my @terms;
687 94 100       174 if (@_) {
688 6     30   15 foreach my $term (__sort_by_id(sub {shift}, values(%{$self->{TERMS}}))) {
  30         58  
  6         13  
689 30 100       47 push @terms, $term if ($term->id() =~ /$_[0]/);
690             }
691             } else {
692             #@terms = $self->{TERMS_SET}->get_set(); # TODO Is this faster than using 'values'?
693             #@terms = __sort_by_id(sub {shift}, $self->{TERMS_SET}->get_set());
694            
695             #@terms = values(%{$self->{TERMS}}); # TODO sort or not?
696 88     5785   273 @terms = __sort_by_id(sub {shift}, values(%{$self->{TERMS}}));
  5785         8427  
  88         1198  
697             }
698 94         1317 return \@terms;
699             }
700              
701             =head2 get_instances
702              
703             Usage - $ontology->get_instances() or $ontology->get_instances("APO:K.*")
704             Returns - the instances held by this ontology as a reference to an array of OBO::Core::Instance's
705             Args - none or the regular expression for filtering the instances by id's
706             Function - returns the instances held by this ontology
707            
708             =cut
709              
710             sub get_instances {
711 46     46 1 97 my $self = shift;
712 46         48 my @instances;
713 46 100       82 if (@_) {
714 6         4 foreach my $instance (sort values(%{$self->{INSTANCES}})) {
  6         35  
715 30 100       49 push @instances, $instance if ($instance->id() =~ /$_[0]/);
716             }
717             } else {
718             #@instances = $self->{INSTANCES_SET}->get_set(); # TODO This INSTANCES_SET was giving wrong results....
719            
720             #@instances = sort values(%{$self->{INSTANCES}}); # TODO sort or not?
721 40     114   107 @instances =__sort_by_id(sub {shift}, values(%{$self->{INSTANCES}}));
  114         362  
  40         116  
722             }
723 46         174 return \@instances;
724             }
725              
726             =head2 get_terms_sorted_by_id
727              
728             Usage - $ontology->get_terms_sorted_by_id() or $ontology->get_terms_sorted_by_id("APO:I.*")
729             Returns - the terms held by this ontology as a reference to a sorted (by ID) array of OBO::Core::Term's
730             Args - none or the regular expression for filtering the terms by id's
731             Function - returns the terms held by this ontology, the terms are sorted by ID (using the Schwartzian Transform)
732            
733             =cut
734              
735             sub get_terms_sorted_by_id {
736 19     19 1 37 my $self = shift;
737 19     3997   91 my @sorted_terms = __sort_by_id(sub {shift}, @{$self->get_terms(@_)});
  3997         5209  
  19         64  
738 19         1083 return \@sorted_terms;
739             }
740              
741             =head2 get_instances_sorted_by_id
742              
743             Usage - $ontology->get_instances_sorted_by_id() or $ontology->get_instances_sorted_by_id("APO:K.*")
744             Returns - the instances held by this ontology as a reference to a sorted (by ID) array of OBO::Core::Instance's
745             Args - none or the regular expression for filtering the instances by id's
746             Function - returns the instances held by this ontology, the instances are sorted by ID (using the Schwartzian Transform)
747            
748             =cut
749              
750             sub get_instances_sorted_by_id {
751 15     15 1 30 my $self = shift;
752 15     16   54 my @sorted_instances = __sort_by_id(sub {shift}, @{$self->get_instances(@_)});
  16         27  
  15         52  
753 15         57 return \@sorted_instances;
754             }
755              
756             =head2 get_terms_by_subnamespace
757              
758             Usage - $ontology->get_terms_by_subnamespace() or $ontology->get_terms_by_subnamespace("P") or or $ontology->get_terms_by_subnamespace("Pa")
759             Returns - the terms held by this ontology corresponding to the requested subnamespace as a reference to an array of OBO::Core::Term's
760             Args - none or the subnamespace: 'P', 'I', 'Pa', 'Ia' and so on.
761             Function - returns the terms held by this ontology corresponding to the requested subnamespace
762            
763             =cut
764              
765             sub get_terms_by_subnamespace {
766 2     2 1 29 my $self = shift;
767 2         3 my $terms;
768 2 50       5 if (@_) {
769 2         5 my $is = $self->get_terms_idspace();
770 2 50       5 if (!defined $is) {
771 0         0 croak 'The local ID space is not defined for this ontology.';
772             } else {
773 2         6 $terms = $self->get_terms($is.':'.$_[0]);
774             }
775             }
776 2         6 return $terms;
777             }
778              
779             =head2 get_instances_by_subnamespace
780              
781             Usage - $ontology->get_instances_by_subnamespace() or $ontology->get_instances_by_subnamespace("K") or or $ontology->get_instances_by_subnamespace("Ka")
782             Returns - the instances held by this ontology corresponding to the requested subnamespace as a reference to an array of OBO::Core::Instance's
783             Args - none or the subnamespace: 'K', 'L', 'Ka', 'La' and so on.
784             Function - returns the instances held by this ontology corresponding to the requested subnamespace
785            
786             =cut
787              
788             sub get_instances_by_subnamespace {
789 2     2 1 55 my $self = shift;
790 2         3 my $instances;
791 2 50       4 if (@_) {
792 2         6 my $is = $self->get_instances_idspace();
793 2 50       5 if (!defined $is) {
794 0         0 croak 'The local ID space is not defined for this ontology.';
795             } else {
796 2         36 $instances = $self->get_instances($is.':'.$_[0]);
797             }
798             }
799 2         5 return $instances;
800             }
801              
802             =head2 get_terms_by_subset
803              
804             Usage - $ontology->get_terms_by_subset("GO_SLIM")
805             Returns - the terms held by this ontology belonging to the given subset as a reference to an array of OBO::Core::Term's
806             Args - a subset name
807             Function - returns the terms held by this ontology belonging to the requested subset
808            
809             =cut
810              
811             sub get_terms_by_subset {
812 2     2 1 7 my ($self, $subset) = @_;
813 2         3 my @terms;
814 2     6   8 foreach my $term (__sort_by_id(sub {shift}, values(%{$self->{TERMS}}))) {
  6         11  
  2         6  
815 6         12 foreach my $ss ($term->subset()) {
816 4 100       58 push @terms, $term if ($ss =~ /$subset/);
817             }
818             }
819 2         11 return \@terms;
820             }
821              
822             =head2 get_instances_by_subset
823              
824             Usage - $ontology->get_instances_by_subset("INSTANCES_SLIM")
825             Returns - the instances held by this ontology belonging to the given subset as a reference to an array of OBO::Core::Instance's
826             Args - a subset name
827             Function - returns the instances held by this ontology belonging to the requested subset
828            
829             =cut
830              
831             sub get_instances_by_subset {
832 2     2 1 3 my ($self, $subset) = @_;
833 2         2 my @instances;
834 2         3 foreach my $instance (sort values(%{$self->{INSTANCES}})) {
  2         12  
835 6         12 foreach my $ss ($instance->subset()) {
836 4 100       26 push @instances, $instance if ($ss =~ /$subset/);
837             }
838             }
839 2         6 return \@instances;
840             }
841              
842             =head2 get_relationships
843              
844             Usage - $ontology->get_relationships()
845             Returns - the relationships held by this ontology as a reference to an array of OBO::Core::Relationship's
846             Args - none
847             Function - returns the relationships held by this ontology
848            
849             =cut
850              
851             sub get_relationships {
852 10     10 1 11 my $self = shift;
853 10         13 my @relationships = sort values(%{$self->{RELATIONSHIPS}});
  10         206  
854 10         26 return \@relationships;
855             }
856              
857             =head2 get_relationship_types
858              
859             Usage - $ontology->get_relationship_types()
860             Returns - a reference to an array with the relationship types (OBO::Core::RelationshipType) held by this ontology
861             Args - none
862             Function - returns the relationship types held by this ontology
863            
864             =cut
865              
866             sub get_relationship_types {
867 27     27 1 23 my $self = shift;
868 27         27 my @relationship_types = sort values(%{$self->{RELATIONSHIP_TYPES}});
  27         195  
869 27         61 return \@relationship_types;
870             }
871              
872             =head2 get_relationship_types_sorted_by_id
873              
874             Usage - $ontology->get_relationship_types_sorted_by_id()
875             Returns - the relationship types held by this ontology as a reference to a sorted (by ID) array of OBO::Core::Term's
876             Args - none or the regular expression for filtering the terms by id's
877             Function - returns the relationship types held by this ontology, the relationship types are sorted by ID (using the Schwartzian Transform)
878            
879             =cut
880              
881             sub get_relationship_types_sorted_by_id {
882 4005     4005 1 3685 my $self = shift;
883 4005     92863   9762 my @sorted_relationship_types = __sort_by_id(sub {shift}, sort values(%{$self->{RELATIONSHIP_TYPES}}));
  92863         127917  
  4005         159743  
884 4005         27247 return \@sorted_relationship_types;
885             }
886              
887             =head2 get_term_local_neighbourhood
888              
889             Usage - $ontology->get_term_local_neighbourhood($term, $rel_type)
890             Returns - the neighbourhood of a given term as a reference to an array with the relationships (OBO::Core::Relationship)
891             Args - the term (OBO::Core::Term) for which its relationships will be found out; and optionally the relationship type name (e.g. 'participates_in') to select only those types of relationships
892             Function - returns the local neighbourhood of the given term as a reference to an array with the relationships (OBO::Core::Relationship)
893             Remark - this subroutine, which is an alias of OBO::Core::get_relationships_by_source_term, might change its interface in the future (a new module, named e.g. TermNeighbourhood, might be implemented)
894            
895             =cut
896              
897             sub get_term_local_neighbourhood {
898 1     1 1 2 my ($self, $term, $rel_type) = @_;
899 1         4 return $self->get_relationships_by_source_term($term, $rel_type);
900             }
901              
902             =head2 get_relationships_by_source_term
903              
904             Usage - $ontology->get_relationships_by_source_term($source_term, $rel_type)
905             Returns - a reference to an array with the relationships (OBO::Core::Relationship) connecting the given term to its children
906             Args - the term (OBO::Core::Term) for which its relationships will be found out; and optionally the relationship type name (e.g. 'participates_in') to filter out those types of relationships
907             Function - returns the relationships associated to the given source term
908            
909             =cut
910              
911             sub get_relationships_by_source_term {
912 9     9 1 94 my ($self, $term, $rel_type) = @_;
913 9         26 my $result = OBO::Util::Set->new();
914 9 50       19 if ($term) {
915 9 100       12 if ($rel_type) {
916 1         1 my @rels = sort values(%{$self->{SOURCE_RELATIONSHIPS}->{$term}->{$rel_type}});
  1         4  
917 1         2 foreach my $rel (@rels) {
918 1         3 $result->add($rel);
919             }
920             } else {
921 8         10 my @hashes = sort values(%{$self->{SOURCE_RELATIONSHIPS}->{$term}});
  8         34  
922 8         13 foreach my $hash (@hashes) {
923 8         9 my @rels = sort values %{$hash};
  8         21  
924 8         11 foreach my $rel (@rels) {
925 12         24 $result->add($rel);
926             }
927             }
928             }
929             }
930 9         25 my @arr = $result->get_set();
931 9         34 return \@arr;
932             }
933              
934             =head2 get_relationships_by_target_term
935              
936             Usage - $ontology->get_relationships_by_target_term($target_term, $rel_type)
937             Returns - a reference to an array with the relationships (OBO::Core::Relationship) connecting the given term to its parents
938             Args - the term (OBO::Core::Term) for which its relationships will be found out; and optionally the relationship type name (e.g. 'participates_in') to filter out those types of relationships
939             Function - returns the relationships associated to the given target term
940            
941             =cut
942              
943             sub get_relationships_by_target_term {
944 99     99 1 202 my ($self, $term, $rel_type) = @_;
945            
946 99         232 my $result = OBO::Util::Set->new();
947 99 50       187 if ($term) {
948 99 100       132 if ($rel_type) {
949 1         2 my @rels = sort values(%{$self->{TARGET_RELATIONSHIPS}->{$term}->{$rel_type}});
  1         4  
950 1         3 foreach my $rel (@rels) {
951 1         3 $result->add($rel);
952             }
953             } else {
954 98         85 my @hashes = sort values(%{$self->{TARGET_RELATIONSHIPS}->{$term}});
  98         339  
955 98         141 foreach my $hash (@hashes) {
956 76         85 my @rels = sort values %{$hash};
  76         262  
957 76         78 foreach my $rel (@rels) {
958 142         238 $result->add($rel);
959             }
960             }
961             }
962             }
963 99         185 my @arr = $result->get_set();
964 99         325 return \@arr;
965             }
966              
967             =head2 get_term_by_id
968              
969             Usage - $ontology->get_term_by_id($id)
970             Returns - the term (OBO::Core::Term) associated to the given ID
971             Args - the term's ID (string)
972             Function - returns the term associated to the given ID
973            
974             =cut
975              
976             sub get_term_by_id {
977 17774     17774 1 21146 my ($self, $id) = @_;
978 17774         33181 return $self->{TERMS}->{$id};
979             }
980              
981             =head2 get_instance_by_id
982              
983             Usage - $ontology->get_instance_by_id($id)
984             Returns - the instance (OBO::Core::Instance) associated to the given ID
985             Args - the instance's ID (string)
986             Function - returns the instance associated to the given ID
987            
988             =cut
989              
990             sub get_instance_by_id {
991 29     29 1 216 my ($self, $id) = @_;
992 29         96 return $self->{INSTANCES}->{$id};
993             }
994              
995             =head2 set_term_id
996              
997             Usage - $ontology->set_term_id($term, $new_term_id)
998             Returns - the term (OBO::Core::Term) with its new ID
999             Args - the term (OBO::Core::Term) and its new term's ID (string)
1000             Function - sets a new term ID for the given term
1001            
1002             =cut
1003              
1004             sub set_term_id {
1005 3     3 1 6 my ($self, $term, $new_term_id) = @_;
1006 3 50 33     18 if ($term && $new_term_id) {
1007 3 50       10 if ($self->has_term($term)) {
1008 3 50       7 if (!$self->has_term_id($new_term_id)) {
1009 3         11 $self->{TERMS_SET}->remove($term);
1010 3         7 my $old_id = $term->id();
1011 3         7 $term->id($new_term_id);
1012 3         7 $self->{TERMS}->{$new_term_id} = $self->{TERMS}->{$old_id};
1013 3         4 delete $self->{TERMS}->{$old_id};
1014 3         11 $self->{TERMS_SET}->add($term);
1015            
1016             # Adapt the relationship ids of this term, e.g., APO:P0000001_is_a_APO:P0000002 => APO:P0000003_is_a_APO:P0000002
1017 3         4 my @outward = @{$self->get_relationships_by_source_term($term)};
  3         10  
1018 3         4 foreach my $r (@outward){
1019 2         5 $self->delete_relationship($r);
1020              
1021 2         5 my $r_id = $r->id();
1022 2         46 (my $new_r_id = $r_id) =~ s/^$old_id(_)/$new_term_id$1/;
1023 2         7 $r->id($new_r_id);
1024 2         5 $self->create_rel($term, $r->type(), $r->head());
1025             }
1026 3         8 my @inward = @{$self->get_relationships_by_target_term($term)};
  3         7  
1027 3         6 foreach my $r (@inward){
1028 1         2 $self->delete_relationship($r);
1029            
1030 1         4 my $r_id = $r->id();
1031 1         20 (my $new_r_id = $r_id) =~ s/(_)$old_id$/$1$new_term_id/;
1032 1         4 $r->id($new_r_id);
1033 1         3 $self->create_rel($r->tail(), $r->type(), $term);
1034             }
1035              
1036 3         9 return $self->{TERMS}->{$new_term_id};
1037             } else {
1038 0         0 croak 'The given new ID (', $new_term_id, ') is already used by: ', $self->get_term_by_id($new_term_id)->name();
1039             }
1040             } else {
1041 0         0 croak 'The term for which you want to modify its ID (', $new_term_id, ') is not in the ontology';
1042             }
1043             }
1044             }
1045              
1046             =head2 set_instance_id
1047              
1048             Usage - $ontology->set_instance_id($instance, $new_id)
1049             Returns - the instance (OBO::Core::Instance) with its new ID
1050             Args - the instance (OBO::Core::Instance) and its new instance's ID (string)
1051             Function - sets a new instance ID for the given instance
1052            
1053             =cut
1054              
1055             sub set_instance_id {
1056 2     2 1 3 my ($self, $instance, $new_instance_id) = @_;
1057 2 50 33     10 if ($instance && $new_instance_id) {
1058 2 50       4 if ($self->has_instance($instance)) {
1059 2 50       3 if (!$self->has_instance_id($new_instance_id)) {
1060 2         5 my $old_id = $instance->id();
1061 2         5 $instance->id($new_instance_id);
1062 2         4 $self->{INSTANCES}->{$new_instance_id} = $self->{INSTANCES}->{$old_id};
1063 2         4 delete $self->{INSTANCES}->{$old_id};
1064             # TODO Adapt the subtype relationship this instance: APO:K0000001_is_a_APO:P0000001 => APO:K0000011_is_a_APO:P0000001
1065 2         5 return $self->{INSTANCES}->{$new_instance_id};
1066             } else {
1067 0         0 croak 'The given new ID (', $new_instance_id, ') is already used by: ', $self->get_instance_by_id($new_instance_id)->name();
1068             }
1069             } else {
1070 0         0 croak 'The instance for which you want to modify its ID (', $new_instance_id, ') is not in the ontology';
1071             }
1072             }
1073             }
1074              
1075             =head2 get_relationship_type_by_id
1076              
1077             Usage - $ontology->get_relationship_type_by_id($id)
1078             Returns - the relationship type (OBO::Core::RelationshipType) associated to the given id
1079             Args - the relationship type's id (string)
1080             Function - returns the relationship type associated to the given id
1081            
1082             =cut
1083              
1084             sub get_relationship_type_by_id {
1085 4689     4689 1 6329 my ($self, $id) = @_;
1086 4689 50       14343 return $self->{RELATIONSHIP_TYPES}->{$id} if ($id);
1087             }
1088              
1089             =head2 get_term_by_name
1090              
1091             Usage - $ontology->get_term_by_name($name)
1092             Returns - the term (OBO::Core::Term) associated to the given name
1093             Args - the term's name (string)
1094             Function - returns the term associated to the given name
1095             Remark - the argument (string) is case sensitive
1096            
1097             =cut
1098              
1099             sub get_term_by_name {
1100 12     12 1 329 my ($self, $name) = ($_[0], $_[1]);
1101 12         15 my $result;
1102 12 50       32 if ($name) {
1103 12         14 foreach my $term (@{$self->get_terms()}) { # return the exact occurrence
  12         32  
1104 893 100 66     1384 $result = $term, last if (defined ($term->name()) && ($term->name() eq $name));
1105             }
1106             }
1107 12         186 return $result;
1108             }
1109              
1110             =head2 get_instance_by_name
1111              
1112             Usage - $ontology->get_instance_by_name($name)
1113             Returns - the instance (OBO::Core::Instance) associated to the given name
1114             Args - the instance's name (string)
1115             Function - returns the instance associated to the given name
1116             Remark - the argument (string) is case sensitive
1117            
1118             =cut
1119              
1120             sub get_instance_by_name {
1121 4     4 1 6 my ($self, $name) = ($_[0], $_[1]);
1122 4         3 my $result;
1123 4 50       9 if ($name) {
1124 4         2 foreach my $instance (@{$self->get_instances()}) { # return the exact occurrence
  4         9  
1125 10 100 66     16 $result = $instance, last if (defined ($instance->name()) && ($instance->name() eq $name));
1126             }
1127             }
1128 4         16 return $result;
1129             }
1130              
1131             =head2 get_term_by_name_or_synonym
1132              
1133             Usage - $ontology->get_term_by_name_or_synonym($name, $scope)
1134             Returns - the term (OBO::Core::Term) associated to the given name or synonym (given its scope, EXACT by default); 'undef' is returned if no term is found.
1135             Args - the term's name or synonym (string) and optionally the scope of the synonym (EXACT by default)
1136             Function - returns the term associated to the given name or synonym (given its scope, EXACT by default)
1137             Remark - this function should be carefully used since among ontologies there may be homonyms at the level of the synonyms (e.g. genes)
1138             Remark - the argument (string) is case sensitive
1139            
1140             =cut
1141              
1142             sub get_term_by_name_or_synonym {
1143 8     8 1 17 my ($self, $name_or_synonym, $scope) = ($_[0], $_[1], $_[2]);
1144 8 50       15 if ($name_or_synonym) {
1145 8   100     16 $scope = $scope || "EXACT";
1146 8         6 foreach my $term (@{$self->get_terms()}) { # return the exact occurrence
  8         12  
1147             # Look up for the 'name'
1148 20         35 my $t_name = $term->name();
1149 20 50 33     70 if (defined ($t_name) && (lc($t_name) eq $name_or_synonym)) {
1150 0         0 return $term;
1151             }
1152             # Look up for its synonyms (and optinal scope)
1153 20         25 foreach my $syn ($term->synonym_set()){
1154 20         33 my $s_text = $syn->def()->text();
1155 20 100 100     71 if (($scope eq "ANY" && $s_text eq $name_or_synonym) ||
      100        
      66        
1156             ($syn->scope() eq $scope && $s_text eq $name_or_synonym)) {
1157 5         17 return $term;
1158             }
1159             }
1160             }
1161             }
1162 3         10 return undef;
1163             }
1164              
1165             =head2 get_instance_by_name_or_synonym
1166              
1167             Usage - $ontology->get_instance_by_name_or_synonym($name, $scope)
1168             Returns - the instance (OBO::Core::Instance) associated to the given name or synonym (given its scope, EXACT by default); 'undef' is returned if no instance is found.
1169             Args - the instance's name or synonym (string) and optionally the scope of the synonym (EXACT by default)
1170             Function - returns the instance associated to the given name or synonym (given its scope, EXACT by default)
1171             Remark - this function should be carefully used since among ontologies there may be homonyms at the level of the synonyms (e.g. locations)
1172             Remark - the argument (string) is case sensitive
1173            
1174             =cut
1175              
1176             sub get_instance_by_name_or_synonym {
1177 8     8 1 14 my ($self, $name_or_synonym, $scope) = ($_[0], $_[1], $_[2]);
1178 8 50       20 if ($name_or_synonym) {
1179 8   100     16 $scope = $scope || "EXACT";
1180 8         10 foreach my $instance (@{$self->get_instances()}) { # return the exact occurrence
  8         15  
1181             # Look up for the 'name'
1182 20         30 my $t_name = $instance->name();
1183 20 50 33     62 if (defined ($t_name) && (lc($t_name) eq $name_or_synonym)) {
1184 0         0 return $instance;
1185             }
1186             # Look up for its synonyms (and optinal scope)
1187 20         34 foreach my $syn ($instance->synonym_set()){
1188 20         39 my $s_text = $syn->def()->text();
1189 20 100 100     67 if (($scope eq "ANY" && $s_text eq $name_or_synonym) ||
      100        
      66        
1190             ($syn->scope() eq $scope && $s_text eq $name_or_synonym)) {
1191 5         20 return $instance;
1192             }
1193             }
1194             }
1195             }
1196 3         9 return undef;
1197             }
1198              
1199             =head2 get_terms_by_name
1200              
1201             Usage - $ontology->get_terms_by_name($name)
1202             Returns - the term set (OBO::Util::TermSet) with all the terms (OBO::Core::Term) having $name in their names
1203             Args - the term name (string)
1204             Function - returns the terms having $name in their names
1205            
1206             =cut
1207              
1208             sub get_terms_by_name {
1209 16     16 1 40 my ($self, $name) = ($_[0], lc($_[1]));
1210 16         15 my $result;
1211 16 50       34 if ($name) {
1212 16         43 $result = OBO::Util::TermSet->new();
1213 16         16 my @terms = @{$self->get_terms()};
  16         33  
1214            
1215             # NB. the following two lines are equivalent to the 'for' loop
1216             #my @found_terms = grep {lc($_->name()) =~ /$name/} @terms;
1217             #$result->add_all(@found_terms);
1218              
1219 16         28 foreach my $term (@terms) { # return the all the occurrences
1220 118 100 66     183 $result->add($term) if (defined ($term->name()) && lc($term->name()) =~ /$name/);
1221             }
1222             }
1223 16         69 return $result;
1224             }
1225              
1226             =head2 get_instances_by_name
1227              
1228             Usage - $ontology->get_instances_by_name($name)
1229             Returns - the instance set (OBO::Util::InstanceSet) with all the instances (OBO::Core::Instance) having $name in their names
1230             Args - the instance name (string)
1231             Function - returns the instances having $name in their names
1232            
1233             =cut
1234              
1235             sub get_instances_by_name {
1236 5     5 1 13 my ($self, $name) = ($_[0], lc($_[1]));
1237 5         8 my $result;
1238 5 50       9 if ($name) {
1239 5         14 $result = OBO::Util::InstanceSet->new();
1240 5         4 my @instances = @{$self->get_instances()};
  5         9  
1241            
1242             # NB. the following two lines are equivalent to the 'for' loop
1243             #my @found_instances = grep {lc($_->name()) =~ /$name/} @instances;
1244             #$result->add_all(@found_instances);
1245              
1246 5         8 foreach my $instance (@instances) { # return the all the occurrences
1247 25 100 66     37 $result->add($instance) if (defined ($instance->name()) && lc($instance->name()) =~ /$name/);
1248             }
1249             }
1250 5         20 return $result;
1251             }
1252              
1253             =head2 get_relationship_types_by_name
1254              
1255             Usage - $ontology->get_relationship_types_by_name($name)
1256             Returns - the relationship types set (OBO::Util::RelationshipTypeSet) with all the relationship types (OBO::Core::RelationshipType) having $name in their names
1257             Args - the relationship type name (string)
1258             Function - returns the relationship type having $name in their names
1259            
1260             =cut
1261              
1262             sub get_relationship_types_by_name {
1263 8     8 1 15 my ($self, $name) = ($_[0], lc($_[1]));
1264 8         6 my $result;
1265 8 50       11 if ($name) {
1266 8         24 $result = OBO::Util::RelationshipTypeSet->new();
1267 8         7 my @relationship_types = @{$self->get_relationship_types()};
  8         12  
1268            
1269             # NB. the following two lines are equivalent to the 'for' loop
1270             #my @found_relationship_types = grep {lc($_->name()) =~ /$name/} @relationship_types;
1271             #$result->add_all(@found_relationship_types);
1272              
1273 8         11 foreach my $relationship_type (@relationship_types) { # return the all the occurrences
1274 40 100 66     58 $result->add($relationship_type) if (defined ($relationship_type->name()) && lc($relationship_type->name()) =~ /$name/);
1275             }
1276             }
1277 8         33 return $result;
1278             }
1279              
1280             =head2 get_relationship_type_by_name
1281              
1282             Usage - $ontology->get_relationship_type_by_name($name)
1283             Returns - the relationship type (OBO::Core::RelationshipType) associated to the given name
1284             Args - the relationship type's name (string)
1285             Function - returns the relationship type associated to the given name
1286            
1287             =cut
1288              
1289             sub get_relationship_type_by_name {
1290 12     12 1 54 my ($self, $name) = ($_[0], lc($_[1]));
1291 12         11 my $result;
1292 12 50       19 if ($name) {
1293 12         14 foreach my $rel_type (@{$self->get_relationship_types()}) { # return the exact occurrence
  12         22  
1294 41 100 100     69 $result = $rel_type, last if (defined ($rel_type->name()) && (lc($rel_type->name()) eq $name));
1295             }
1296             }
1297 12         65 return $result;
1298             }
1299              
1300             =head2 add_relationship
1301              
1302             Usage - $ontology->add_relationship($relationship)
1303             Returns - none
1304             Args - the relationship (OBO::Core::Relationship) to be added between two existing terms or two relationship types
1305             Function - adds a relationship between either two terms or two relationship types.
1306             Remark - If the terms or relationship types bound by this relationship are not yet in the ontology, they will be added
1307             Remark - if you are adding relationships to an ontology, sometimes it might be better to add their type first (usually if you are building a new ontology from an extant one)
1308            
1309             =cut
1310              
1311             sub add_relationship {
1312 3451     3451 1 3321 my ($self, $relationship) = @_;
1313              
1314 3451         5493 my $rel_id = $relationship->id();
1315 3451         5417 my $rel_type = $relationship->type();
1316            
1317 3451 50       5254 $rel_id || croak 'The relationship to be added to this ontology does not have an ID';
1318 3451 50       4533 $rel_type || croak 'The relationship to be added to this ontology does not have an TYPE';
1319            
1320 3451         8899 $self->{RELATIONSHIPS}->{$rel_id} = $relationship;
1321            
1322             #
1323             # Are the target and source elements (term or relationship type) connected by $relationship already in this ontology? if not, add them.
1324             #
1325 3451         4469 my $r = $self->{RELATIONSHIPS}->{$rel_id};
1326 3451         5641 my $target_element = $r->head();
1327 3451         5625 my $source_element = $r->tail();
1328            
1329 3451 100 66     3581 if (eval { $target_element->isa('OBO::Core::Term') } && eval { $source_element->isa('OBO::Core::Term') }) {
  3451 50 33     11495  
  3389 0 0     9936  
    0 0        
1330 3389 100       5537 $self->has_term($target_element) || $self->add_term($target_element);
1331 3389 100       4616 $self->has_term($source_element) || $self->add_term($source_element);
1332 62         193 } elsif (eval { $target_element->isa('OBO::Core::RelationshipType') } && eval { $source_element->isa('OBO::Core::RelationshipType') }) {
  62         201  
1333 62 50       109 $self->has_relationship_type($target_element) || $self->add_relationship_type($target_element);
1334 62 50       96 $self->has_relationship_type($source_element) || $self->add_relationship_type($source_element);
1335 0         0 } elsif (eval { $target_element->isa('OBO::Core::Term') } && eval { $source_element->isa('OBO::Core::Instance') }) { # TODO Do we need this? or better add $self->{PROPERTY_VALUES}?
  0         0  
1336 0 0       0 $self->has_term($target_element) || $self->add_term($target_element);
1337 0 0       0 $self->has_instance($source_element) || $self->add_instance($source_element);
1338 0         0 } elsif (eval { $target_element->isa('OBO::Core::Instance') } && eval { $source_element->isa('OBO::Core::Instance') }) { # TODO Do we need this? or better add $self->{PROPERTY_VALUES}?
  0         0  
1339 0 0       0 $self->has_instance($target_element) || $self->add_instance($target_element);
1340 0 0       0 $self->has_instance($source_element) || $self->add_instance($source_element);
1341             } else {
1342 0         0 croak "An unrecognized object type (nor a Term, nor a RelationshipType) was found as part of the relationship with ID: '", $rel_id, "'";
1343             }
1344            
1345             #
1346             # add the relationship type
1347             #
1348 3451 100       6456 if (!$self->has_relationship_type_id($rel_type) ){
1349 36         165 my $new_rel_type = OBO::Core::RelationshipType->new();
1350 36         94 $new_rel_type->id($rel_type);
1351 36         143 $self->{RELATIONSHIP_TYPES}->{$rel_type} = $new_rel_type;
1352             }
1353            
1354             # for getting children and parents
1355 3451         6994 my $head = $relationship->head();
1356 3451         5345 my $type = $relationship->type();
1357 3451         5303 my $tail = $relationship->tail();
1358 3451         12663 $self->{TARGET_RELATIONSHIPS}->{$head}->{$type}->{$tail} = $relationship;
1359 3451         10407 $self->{SOURCE_RELATIONSHIPS}->{$tail}->{$type}->{$head} = $relationship;
1360 3451         19176 $self->{TARGET_SOURCE_RELATIONSHIPS}->{$tail}->{$head}->{$type} = $relationship;
1361             }
1362              
1363             =head2 get_relationship_by_id
1364              
1365             Usage - print $ontology->get_relationship_by_id()
1366             Returns - the relationship (OBO::Core::Relationship) associated to the given id
1367             Args - the relationship id (string)
1368             Function - returns the relationship associated to the given relationship id
1369            
1370             =cut
1371              
1372             sub get_relationship_by_id {
1373 217     217 1 219 my ($self, $id) = @_;
1374 217         400 return $self->{RELATIONSHIPS}->{$id};
1375             }
1376              
1377             =head2 create_rel
1378              
1379             Usage - $ontology->create_rel($tail, $type, $head)
1380             Returns - the OBO::Core::Ontology object
1381             Args - an OBO::Core::(Term|Relationship) object, a relationship type string (e.g. 'is_a'), and an OBO::Core::(Term|Relationship) object
1382             Function - creates and adds a new relationship (between two terms or relationships) to this ontology
1383            
1384             =cut
1385              
1386             sub create_rel {
1387 222     222 1 329 my $self = shift;
1388 222         261 my ($tail, $type, $head) = @_;
1389            
1390 222 50       440 croak "Not a valid relationship type: '", $type, "'" unless($self->{RELATIONSHIP_TYPES}->{$type});
1391            
1392 222 50 33     697 if ($tail && $head) {
1393 222         475 my $id = $tail->id().'_'.$type.'_'.$head->id();
1394            
1395 222 100       378 if ($self->has_relationship_id($id)) {
1396             #cluck 'The following rel ID already exists in the ontology: ', $id; # Implement a RelationshipSet?
1397            
1398 26         44 my $relationship = $self->get_relationship_by_id($id);
1399 26         57 $self->{TARGET_RELATIONSHIPS}->{$head}->{$type}->{$tail} = $relationship;
1400 26         47 $self->{SOURCE_RELATIONSHIPS}->{$tail}->{$type}->{$head} = $relationship;
1401 26         61 $self->{TARGET_SOURCE_RELATIONSHIPS}->{$tail}->{$head}->{$type} = $relationship;
1402             } else {
1403 196         440 my $rel = OBO::Core::Relationship->new();
1404 196         368 $rel->type($type);
1405 196         366 $rel->link($tail, $head);
1406 196         329 $rel->id($id);
1407 196         299 $self->add_relationship($rel);
1408             }
1409             } else {
1410 0         0 croak 'To create a relationship, you must provide both a tail object and a head object!';
1411             }
1412 222         537 return $self;
1413             }
1414              
1415             =head2 get_child_terms
1416              
1417             Usage - $ontology->get_child_terms($term)
1418             Returns - a reference to an array with the child terms (OBO::Core::Term) of the given term
1419             Args - the term (OBO::Core::Term) for which the children will be found
1420             Function - returns the child terms of the given term
1421            
1422             =cut
1423              
1424             sub get_child_terms {
1425 221     221 1 201 my ($self, $term) = @_;
1426 221         376 my $result = OBO::Util::TermSet->new();
1427 221 50       327 if ($term) {
1428 221         163 my @hashes = values(%{$self->{TARGET_RELATIONSHIPS}->{$term}});
  221         509  
1429 221         266 foreach my $hash (@hashes) {
1430 122         87 my @rels = sort values %{$hash};
  122         274  
1431 122         114 foreach my $rel (@rels) {
1432 166         323 $result->add($rel->tail());
1433             }
1434             }
1435             }
1436 221         369 my @arr = $result->get_set();
1437 221         543 return \@arr;
1438             }
1439              
1440             =head2 get_parent_terms
1441              
1442             Usage - $ontology->get_parent_terms($term)
1443             Returns - a reference to an array with the parent terms (OBO::Core::Term) of the given term
1444             Args - the term (OBO::Core::Term) for which the parents will be found
1445             Function - returns the parent terms of the given term
1446            
1447             =cut
1448              
1449             sub get_parent_terms {
1450 22912     22912 1 19681 my ($self, $term) = @_;
1451 22912         47781 my $result = OBO::Util::TermSet->new();
1452 22912 50       33858 if ($term) {
1453 22912         19471 my @hashes = sort values(%{$self->{SOURCE_RELATIONSHIPS}->{$term}});
  22912         63052  
1454 22912         26667 foreach my $hash (@hashes) {
1455 21203         14553 my @rels = sort values %{$hash};
  21203         52497  
1456 21203         18591 foreach my $rel (@rels) {
1457 40863         69608 $result->add($rel->head());
1458             }
1459             }
1460             }
1461 22912         41696 my @arr = $result->get_set();
1462 22912         66509 return \@arr;
1463             }
1464              
1465             =head2 get_head_by_relationship_type
1466              
1467             Usage - $ontology->get_head_by_relationship_type($term, $relationship_type) or $ontology->get_head_by_relationship_type($rel_type, $relationship_type)
1468             Returns - a reference to an array of terms (OBO::Core::Term) or relationship types (OBO::Core::RelationshipType) pointed out by the relationship of the given type; otherwise undef
1469             Args - the term (OBO::Core::Term) or relationship type (OBO::Core::RelationshipType) and the pointing relationship type (OBO::Core::RelationshipType)
1470             Function - returns the terms or relationship types pointed out by the relationship of the given type
1471            
1472             =cut
1473              
1474             sub get_head_by_relationship_type {
1475 93744     93744 1 79348 my ($self, $element, $relationship_type) = @_;
1476 93744         64109 my @heads;
1477 93744 100 66     263392 if ($element && $relationship_type) {
1478 93718         137770 my $relationship_type_id = $relationship_type->id();
1479            
1480 93718         72012 my @hashes = sort values(%{$self->{SOURCE_RELATIONSHIPS}->{$element}});
  93718         245662  
1481 93718         95052 foreach my $hash (@hashes) {
1482 126563         83413 my @rels = sort values %{$hash};
  126563         190205  
1483 126563         109648 foreach my $rel (@rels) {
1484 140702 100       211016 push @heads, $rel->head() if ($rel->type() eq $relationship_type_id);
1485             #Fix for some cases: push @heads, $rel->head() if ($rel->type() eq $relationship_type->name());
1486             }
1487             }
1488             }
1489 93744         165140 return \@heads;
1490             }
1491              
1492             =head2 get_tail_by_relationship_type
1493              
1494             Usage - $ontology->get_tail_by_relationship_type($term, $relationship_type) or $ontology->get_tail_by_relationship_type($rel_type, $relationship_type)
1495             Returns - a reference to an array of terms (OBO::Core::Term) or relationship types (OBO::Core::RelationshipType) pointing out the given term by means of the given relationship type; otherwise undef
1496             Args - the term (OBO::Core::Term) or relationship type (OBO::Core::RelationshipType) and the relationship type (OBO::Core::RelationshipType)
1497             Function - returns the terms or relationship types pointing out the given term by means of the given relationship type
1498            
1499             =cut
1500              
1501             sub get_tail_by_relationship_type {
1502 10     10 1 36 my ($self, $element, $relationship_type) = @_;
1503 10         7 my @tails;
1504 10 50 33     33 if ($element && $relationship_type) {
1505 10         22 my $relationship_type_id = $relationship_type->id();
1506            
1507 10         12 my @hashes = sort values(%{$self->{TARGET_RELATIONSHIPS}->{$element}});
  10         66  
1508 10         14 foreach my $hash (@hashes) {
1509 13         10 my @rels = sort values %{$hash};
  13         21  
1510 13         24 foreach my $rel (@rels) {
1511 13 100       25 push @tails, $rel->tail() if ($rel->type() eq $relationship_type_id);
1512             }
1513             }
1514             }
1515 10         24 return \@tails;
1516             }
1517              
1518             =head2 get_root_terms
1519              
1520             Usage - $ontology->get_root_terms()
1521             Returns - the root term(s) held by this ontology (as a reference to an array of OBO::Core::Term's)
1522             Args - none
1523             Function - returns the root term(s) held by this ontology
1524            
1525             =cut
1526              
1527             sub get_root_terms {
1528 4     4 1 14 my $self = shift;
1529 4         5 my @roots = ();
1530 4         14 my $term_set = OBO::Util::TermSet->new();
1531            
1532 4     53   19 $term_set->add_all(__sort_by_id(sub {shift}, values(%{$self->{TERMS}})));
  53         116  
  4         23  
1533 4         29 my @arr = $term_set->get_set();
1534            
1535 4         34 while ($term_set->size() > 0) {
1536 50         53 my $term = pop @arr;
1537 50         41 my @hashes = sort values(%{$self->{SOURCE_RELATIONSHIPS}->{$term}});
  50         139  
1538            
1539 50 100       70 if ($#hashes == -1) { # if there are no parents
1540 14         13 push @roots, $term; # it must be a root term
1541 14         29 $term_set->remove($term);
1542             } else { # if it is NOT a root term
1543 36         37 my @queue = ($term);
1544 36         48 while (scalar(@queue) > 0) {
1545 129         96 my $unqueued = shift @queue;
1546 129         206 my $rcode = $term_set->remove($unqueued); # remove the nodes that need not be visited
1547 129         112 my @children = @{$self->get_child_terms($unqueued)};
  129         161  
1548 129         302 @queue = (@queue, @children);
1549             }
1550 36         62 @arr = $term_set->get_set();
1551             }
1552             }
1553 4         21 return \@roots;
1554             }
1555              
1556             =head2 get_number_of_terms
1557              
1558             Usage - $ontology->get_number_of_terms()
1559             Returns - the number of terms held by this ontology
1560             Args - none
1561             Function - returns the number of terms held by this ontology
1562            
1563             =cut
1564              
1565             sub get_number_of_terms {
1566 34     34 1 274 my $self = shift;
1567 34         33 return scalar values(%{$self->{TERMS}});
  34         162  
1568             }
1569              
1570             =head2 get_number_of_instances
1571              
1572             Usage - $ontology->get_number_of_instances()
1573             Returns - the number of instances held by this ontology
1574             Args - none
1575             Function - returns the number of instances held by this ontology
1576            
1577             =cut
1578              
1579             sub get_number_of_instances {
1580 10     10 1 17 my $self = shift;
1581 10         10 return scalar values(%{$self->{INSTANCES}});
  10         35  
1582             }
1583              
1584             =head2 get_number_of_relationships
1585              
1586             Usage - $ontology->get_number_of_relationships()
1587             Returns - the number of relationships held by this ontology
1588             Args - none
1589             Function - returns the number of relationships held by this ontology
1590            
1591             =cut
1592              
1593             sub get_number_of_relationships {
1594 43     43 1 55 my $self = shift;
1595 43         31 return scalar values(%{$self->{RELATIONSHIPS}});
  43         151  
1596             }
1597              
1598             =head2 get_number_of_relationship_types
1599              
1600             Usage - $ontology->get_number_of_relationship_types()
1601             Returns - the number of relationship types held by this ontology
1602             Args - none
1603             Function - returns the number of relationship types held by this ontology
1604            
1605             =cut
1606              
1607             sub get_number_of_relationship_types {
1608 8     8 1 26 my $self = shift;
1609 8         8 return scalar values(%{$self->{RELATIONSHIP_TYPES}});
  8         24  
1610             }
1611              
1612             =head2 export2obo
1613              
1614             See - OBO::Core::Ontology::export()
1615            
1616             =cut
1617              
1618             sub export2obo {
1619            
1620 8     8 1 18 my ($self, $output_file_handle, $error_file_handle) = @_;
1621            
1622             #######################################################################
1623             #
1624             # preambule: OBO header tags
1625             #
1626             #######################################################################
1627 8         61 print $output_file_handle "format-version: 1.4\n";
1628 8         34 my $data_version = $self->data_version();
1629 8 100       26 print $output_file_handle 'data-version:', $data_version, "\n" if ($data_version);
1630            
1631 8         28 my $ontology_id_space = $self->id();
1632 8 100       24 print $output_file_handle 'ontology:', $ontology_id_space, "\n" if ($ontology_id_space);
1633 8         31 chomp(my $local_date = __date()); # `date '+%d:%m:%Y %H:%M'` # date: 11:05:2008 12:52
1634 8 100       38 print $output_file_handle 'date: ', (defined $self->date())?$self->date():$local_date, "\n";
1635            
1636 8         26 my $saved_by = $self->saved_by();
1637 8 100       55 print $output_file_handle 'saved-by: ', $saved_by, "\n" if (defined $saved_by);
1638 8         28 print $output_file_handle "auto-generated-by: ONTO-PERL $VERSION\n";
1639            
1640             # import
1641 8         37 foreach my $import (sort {lc($a) cmp lc($b)} $self->imports()->get_set()) {
  0         0  
1642 1         6 print $output_file_handle 'import: ', $import, "\n";
1643             }
1644            
1645             # subsetdef
1646 8         35 foreach my $subsetdef (sort {lc($a->name()) cmp lc($b->name())} $self->subset_def_map()->values()) {
  26         46  
1647 19         39 print $output_file_handle 'subsetdef: ', $subsetdef->as_string(), "\n";
1648             }
1649            
1650             # synonyntypedef
1651 8         34 foreach my $st (sort {lc($a->name()) cmp lc($b->name())} $self->synonym_type_def_set()->get_set()) {
  1         6  
1652 3         14 print $output_file_handle 'synonymtypedef: ', $st->as_string(), "\n";
1653             }
1654              
1655             # idspace's
1656 8         81 foreach my $idspace ($self->idspaces()->get_set()) {
1657 4         21 print $output_file_handle 'idspace: ', $idspace->as_string(), "\n";
1658             }
1659            
1660             # default_relationship_id_prefix
1661 8         29 my $dris = $self->default_relationship_id_prefix();
1662 8 100       30 print $output_file_handle 'default_relationship_id_prefix: ', $dris, "\n" if (defined $dris);
1663            
1664             # default_namespace
1665 8         26 my $dns = $self->default_namespace();
1666 8 100       32 print $output_file_handle 'default-namespace: ', $dns, "\n" if (defined $dns);
1667            
1668             # remark's
1669 8         26 foreach my $remark ($self->remarks()->get_set()) {
1670 5         24 print $output_file_handle 'remark: ', $remark, "\n";
1671             }
1672            
1673             # treat-xrefs-as-equivalent
1674 8         33 foreach my $id_space_xref_eq (sort {lc($a) cmp lc($b)} $self->treat_xrefs_as_equivalent()->get_set()) {
  1         6  
1675 2         8 print $output_file_handle 'treat-xrefs-as-equivalent: ', $id_space_xref_eq, "\n";
1676             }
1677            
1678             # treat_xrefs_as_is_a
1679 8         33 foreach my $id_space_xref_eq (sort {lc($a) cmp lc($b)} $self->treat_xrefs_as_is_a()->get_set()) {
  1         5  
1680 2         8 print $output_file_handle 'treat-xrefs-as-is_a: ', $id_space_xref_eq, "\n";
1681             }
1682            
1683             #######################################################################
1684             #
1685             # terms
1686             #
1687             #######################################################################
1688 8         16 my @all_terms = @{$self->get_terms_sorted_by_id()};
  8         31  
1689 8         36 foreach my $term (@all_terms) {
1690             #
1691             # [Term]
1692             #
1693 756         914 print $output_file_handle "\n[Term]";
1694            
1695             #
1696             # id
1697             #
1698 756         1679 print $output_file_handle "\nid: ", $term->id();
1699            
1700             #
1701             # is_anonymous
1702             #
1703 756 100       1428 print $output_file_handle "\nis_anonymous: true" if ($term->is_anonymous());
1704              
1705             #
1706             # name
1707             #
1708 756 100       1305 if (defined $term->name()) { # from OBO 1.4, the name is not mandatory anymore
1709 746         1245 print $output_file_handle "\nname: ", $term->name();
1710             }
1711              
1712             #
1713             # namespace
1714             #
1715 756         1565 foreach my $ns ($term->namespace()) {
1716 12         28 print $output_file_handle "\nnamespace: ", $ns;
1717             }
1718            
1719             #
1720             # alt_id
1721             #
1722 756         1589 foreach my $alt_id ($term->alt_id()->get_set()) {
1723 0         0 print $output_file_handle "\nalt_id: ", $alt_id;
1724             }
1725            
1726             #
1727             # builtin
1728             #
1729 756 50       1481 print $output_file_handle "\nbuiltin: true" if ($term->builtin());
1730            
1731             #
1732             # property_value
1733             #
1734 756         1592 my @property_values = sort {$a->id() cmp $b->id()} $term->property_value()->get_set();
  3         7  
1735 756         1155 foreach my $value (@property_values) {
1736 4 100       10 if (defined $value->head()->instance_of()) {
1737 3         8 print $output_file_handle "\nproperty_value: ".$value->type().' "'.$value->head()->id().'" '.$value->head()->instance_of()->id();
1738             } else {
1739 1         4 print $output_file_handle "\nproperty_value: ".$value->type().' '.$value->head()->id();
1740             }
1741             }
1742            
1743             #
1744             # def
1745             #
1746             # QUICK FIX due to some odd files (e.g. IntAct data)
1747 756 100       1448 if (defined $term->def()->text()) {
1748 530         971 my $def_as_string = $term->def_as_string();
1749 530         1579 $def_as_string =~ s/\n+//g;
1750 530         855 $def_as_string =~ s/\r+//g;
1751 530         754 $def_as_string =~ s/\t+//g;
1752 530         2348 print $output_file_handle "\ndef: ", $def_as_string;
1753             }
1754            
1755             #
1756             # comment
1757             #
1758 756 100       1580 print $output_file_handle "\ncomment: ", $term->comment() if (defined $term->comment());
1759            
1760             #
1761             # subset
1762             #
1763 756         1430 foreach my $sset_name (sort {$a cmp $b} $term->subset()) {
  35         39  
1764 34 50       69 if ($self->subset_def_map()->contains_key($sset_name)) {
1765 34         107 print $output_file_handle "\nsubset: ", $sset_name;
1766             } else {
1767 0         0 print $error_file_handle "\nThe term ", $term->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n";
1768             }
1769             }
1770              
1771             #
1772             # synonym
1773             #
1774 839         1128 my @sorted_defs = map { $_->[0] } # restore original values
  876         1134  
1775 839         1701 sort { $a->[1] cmp $b->[1] } # sort
1776 756         1790 map { [$_, lc($_->def()->text())] } # transform: value, sortkey
1777             $term->synonym_set();
1778 756         1452 foreach my $synonym (@sorted_defs) {
1779 839         1435 my $stn = $synonym->synonym_type_name();
1780 839 100       1130 if (defined $stn) {
1781 3         9 print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$stn.' '.$synonym->def()->dbxref_set_as_string();
1782             } else {
1783 836         1530 print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$synonym->def()->dbxref_set_as_string();
1784             }
1785             }
1786            
1787             #
1788             # xref
1789             #
1790 756     533   3497 my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $term->xref_set_as_string());
  533         1513  
  533         981  
1791 756         2192 foreach my $xref (@sorted_xrefs) {
1792 533         1140 print $output_file_handle "\nxref: ", $xref->as_string();
1793             }
1794            
1795             #
1796             # is_a
1797             #
1798 756         1675 my $rt = $self->get_relationship_type_by_id('is_a');
1799 756 50       1263 if (defined $rt) {
1800 756         609 my %saw_is_a; # avoid duplicated arrows (RelationshipSet?)
1801 756     647   1655 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  647         2086  
  756         1226  
1802 756         3228 foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) {
1803 647         1195 my $is_a_txt = "\nis_a: ".$head->id();
1804 647         1343 my $head_name = $head->name();
1805 647 100       1357 $is_a_txt .= ' ! '.$head_name if (defined $head_name);
1806 647         1933 print $output_file_handle $is_a_txt;
1807             }
1808             }
1809              
1810             #
1811             # intersection_of (at least 2 entries)
1812             #
1813 756         1612 foreach my $tr ($term->intersection_of()) {
1814 0         0 my $tr_head = $tr->head();
1815 0         0 my $tr_type = $tr->type();
1816 0         0 my $intersection_of_name = $tr_head->name();
1817 0         0 my $intersection_of_txt = "\nintersection_of: ";
1818 0 0       0 $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil');
1819 0         0 $intersection_of_txt .= $tr_head->id();
1820 0 0       0 $intersection_of_txt .= ' ! '.$intersection_of_name if (defined $intersection_of_name);
1821 0         0 print $output_file_handle $intersection_of_txt;
1822             }
1823              
1824             #
1825             # union_of (at least 2 entries)
1826             #
1827 756         1581 foreach my $tr ($term->union_of()) {
1828 0         0 print $output_file_handle "\nunion_of: ", $tr;
1829             }
1830            
1831             #
1832             # disjoint_from
1833             #
1834 756         1636 foreach my $disjoint_term_id ($term->disjoint_from()) {
1835 7         17 my $disjoint_from_txt = "\ndisjoint_from: ".$disjoint_term_id;
1836 7         23 my $dt = $self->get_term_by_id($disjoint_term_id);
1837 7 50       30 my $dt_name = $dt->name() if (defined $dt);
1838 7 50       26 $disjoint_from_txt .= ' ! '.$dt_name if (defined $dt_name);
1839 7         18 print $output_file_handle $disjoint_from_txt;
1840             }
1841            
1842             #
1843             # relationship
1844             #
1845 756         823 my %saw1;
1846 756         695 my @sorted_rel_types = @{$self->get_relationship_types_sorted_by_id()};
  756         1182  
1847 756         15364 foreach my $rt (grep (!$saw1{$_}++, @sorted_rel_types)) { # use this foreach-line if there are duplicated rel's
1848 20409         35139 my $rt_id = $rt->id();
1849 20409 100       32394 if ($rt_id ne 'is_a') { # is_a is printed above
1850 19653         13414 my %saw2;
1851 19653     446   34232 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  446         1355  
  19653         24730  
1852 19653         50923 foreach my $head (grep (!$saw2{$_}++, @sorted_heads)) { # use this foreach-line if there are duplicated rel's
1853 446         1228 my $relationship_txt = "\nrelationship: ".$rt_id.' '.$head->id();
1854 446         1131 my $relationship_name = $head->name();
1855 446 100       926 $relationship_txt .= ' ! '.$relationship_name if (defined $relationship_name);
1856 446         2091 print $output_file_handle $relationship_txt;
1857             }
1858             }
1859             }
1860              
1861             #
1862             # created_by
1863             #
1864 756 100       1757 print $output_file_handle "\ncreated_by: ", $term->created_by() if (defined $term->created_by());
1865              
1866             #
1867             # creation_date
1868             #
1869 756 100       1392 print $output_file_handle "\ncreation_date: ", $term->creation_date() if (defined $term->creation_date());
1870            
1871             #
1872             # modified_by
1873             #
1874 756 50       1356 print $output_file_handle "\nmodified_by: ", $term->modified_by() if (defined $term->modified_by());
1875              
1876             #
1877             # modification_date
1878             #
1879 756 50       1359 print $output_file_handle "\nmodification_date: ", $term->modification_date() if (defined $term->modification_date());
1880            
1881             #
1882             # is_obsolete
1883             #
1884 756 50       1285 print $output_file_handle "\nis_obsolete: true" if ($term->is_obsolete());
1885              
1886             #
1887             # replaced_by
1888             #
1889 756         1398 foreach my $replaced_by ($term->replaced_by()->get_set()) {
1890 0         0 print $output_file_handle "\nreplaced_by: ", $replaced_by;
1891             }
1892            
1893             #
1894             # consider
1895             #
1896 756         1573 foreach my $consider ($term->consider()->get_set()) {
1897 0         0 print $output_file_handle "\nconsider: ", $consider;
1898             }
1899            
1900             #
1901             # end
1902             #
1903 756         4718 print $output_file_handle "\n";
1904             }
1905              
1906             #######################################################################
1907             #
1908             # instances
1909             #
1910             #######################################################################
1911 8         38 my @all_instances = @{$self->get_instances_sorted_by_id()};
  8         32  
1912 8         20 foreach my $instance (@all_instances) {
1913             #
1914             # [Instance]
1915             #
1916 4         5 print $output_file_handle "\n[Instance]";
1917            
1918             #
1919             # id
1920             #
1921 4         10 print $output_file_handle "\nid: ", $instance->id();
1922            
1923             #
1924             # is_anonymous
1925             #
1926 4 50       10 print $output_file_handle "\nis_anonymous: true" if ($instance->is_anonymous());
1927              
1928             #
1929             # name
1930             #
1931 4 100       9 if (defined $instance->name()) { # from OBO 1.4, the name is not mandatory anymore
1932 2         4 print $output_file_handle "\nname: ", $instance->name();
1933             }
1934              
1935             #
1936             # namespace
1937             #
1938 4         9 foreach my $ns ($instance->namespace()) {
1939 0         0 print $output_file_handle "\nnamespace: ", $ns;
1940             }
1941            
1942             #
1943             # alt_id
1944             #
1945 4         10 foreach my $alt_id ($instance->alt_id()->get_set()) {
1946 0         0 print $output_file_handle "\nalt_id: ", $alt_id;
1947             }
1948            
1949             #
1950             # builtin
1951             #
1952 4 50       10 print $output_file_handle "\nbuiltin: true" if ($instance->builtin());
1953              
1954             #
1955             # comment
1956             #
1957 4 50       8 print $output_file_handle "\ncomment: ", $instance->comment() if (defined $instance->comment());
1958            
1959             #
1960             # subset
1961             #
1962 4         10 foreach my $sset_name (sort {$a cmp $b} $instance->subset()) {
  0         0  
1963 0 0       0 if ($self->subset_def_map()->contains_key($sset_name)) {
1964 0         0 print $output_file_handle "\nsubset: ", $sset_name;
1965             } else {
1966 0         0 print $error_file_handle "\nThe instance ", $instance->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n";
1967             }
1968             }
1969              
1970             #
1971             # synonym
1972             #
1973 0         0 my @sorted_defs = map { $_->[0] } # restore original values
  0         0  
1974 0         0 sort { $a->[1] cmp $b->[1] } # sort
1975 4         10 map { [$_, lc($_->def()->text())] } # transform: value, sortkey
1976             $instance->synonym_set();
1977 4         7 foreach my $synonym (@sorted_defs) {
1978 0         0 my $stn = $synonym->synonym_type_name();
1979 0 0       0 if (defined $stn) {
1980 0         0 print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$stn.' '.$synonym->def()->dbxref_set_as_string();
1981             } else {
1982 0         0 print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$synonym->def()->dbxref_set_as_string();
1983             }
1984             }
1985            
1986             #
1987             # xref
1988             #
1989 4     0   22 my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $instance->xref_set_as_string());
  0         0  
  0         0  
1990 4         11 foreach my $xref (@sorted_xrefs) {
1991 0         0 print $output_file_handle "\nxref: ", $xref->as_string();
1992             }
1993              
1994             #
1995             # instance_of
1996             #
1997 4         12 my $class = $instance->instance_of();
1998 4 100       8 if ($class) {
1999 2         7 my $instance_of_txt = "\ninstance_of: ".$class->id();
2000 2         6 my $class_name = $class->name();
2001 2 50       5 $instance_of_txt .= ' ! '.$class_name if (defined $class_name);
2002 2         6 print $output_file_handle $instance_of_txt;
2003             }
2004              
2005             #
2006             # property_value
2007             #
2008 4         9 my @property_values = sort {$a->id() cmp $b->id()} $instance->property_value()->get_set();
  4         7  
2009 4         7 foreach my $value (@property_values) {
2010             # TODO Finalise this implementation
2011 5         10 print $output_file_handle "\nproperty_value: ".$value->type().' '.$value->head()->id();
2012             }
2013              
2014             #
2015             # intersection_of (at least 2 entries)
2016             #
2017 4         9 foreach my $tr ($instance->intersection_of()) {
2018 0         0 my $tr_head = $tr->head();
2019 0         0 my $tr_type = $tr->type();
2020 0         0 my $intersection_of_name = $tr_head->name();
2021 0         0 my $intersection_of_txt = "\nintersection_of: ";
2022 0 0       0 $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil');
2023 0         0 $intersection_of_txt .= $tr_head->id();
2024 0 0       0 $intersection_of_txt .= ' ! '.$intersection_of_name if (defined $intersection_of_name);
2025 0         0 print $output_file_handle $intersection_of_txt;
2026             }
2027              
2028             #
2029             # union_of (at least 2 entries)
2030             #
2031 4         10 foreach my $tr ($instance->union_of()) {
2032 0         0 print $output_file_handle "\nunion_of: ", $tr;
2033             }
2034            
2035             #
2036             # disjoint_from
2037             #
2038 4         10 foreach my $disjoint_instance_id ($instance->disjoint_from()) {
2039 0         0 my $disjoint_from_txt = "\ndisjoint_from: ".$disjoint_instance_id;
2040 0         0 my $dt = $self->get_instance_by_id($disjoint_instance_id);
2041 0 0       0 my $dt_name = $dt->name() if (defined $dt);
2042 0 0       0 $disjoint_from_txt .= ' ! '.$dt_name if (defined $dt_name);
2043 0         0 print $output_file_handle $disjoint_from_txt;
2044             }
2045            
2046             #
2047             # relationship
2048             #
2049 4         4 my %saw1;
2050 4         4 my @sorted_rel_types = @{$self->get_relationship_types_sorted_by_id()};
  4         7  
2051 4         39 foreach my $rt (grep (!$saw1{$_}++, @sorted_rel_types)) { # use this foreach-line if there are duplicated rel's
2052 44         70 my $rt_id = $rt->id();
2053 44 100       69 if ($rt_id ne 'is_a') { # is_a is printed above
2054 40         26 my %saw2;
2055 40     0   68 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($instance, $rt)});
  0         0  
  40         45  
2056 40         100 foreach my $head (grep (!$saw2{$_}++, @sorted_heads)) { # use this foreach-line if there are duplicated rel's
2057 0         0 my $relationship_txt = "\nrelationship: ".$rt_id.' '.$head->id();
2058 0         0 my $relationship_name = $head->name();
2059 0 0       0 $relationship_txt .= ' ! '.$relationship_name if (defined $relationship_name);
2060 0         0 print $output_file_handle $relationship_txt;
2061             }
2062             }
2063             }
2064              
2065             #
2066             # created_by
2067             #
2068 4 50       9 print $output_file_handle "\ncreated_by: ", $instance->created_by() if (defined $instance->created_by());
2069              
2070             #
2071             # creation_date
2072             #
2073 4 50       8 print $output_file_handle "\ncreation_date: ", $instance->creation_date() if (defined $instance->creation_date());
2074            
2075             #
2076             # modified_by
2077             #
2078 4 50       9 print $output_file_handle "\nmodified_by: ", $instance->modified_by() if (defined $instance->modified_by());
2079              
2080             #
2081             # modification_date
2082             #
2083 4 50       8 print $output_file_handle "\nmodification_date: ", $instance->modification_date() if (defined $instance->modification_date());
2084            
2085             #
2086             # is_obsolete
2087             #
2088 4 50       9 print $output_file_handle "\nis_obsolete: true" if ($instance->is_obsolete());
2089              
2090             #
2091             # replaced_by
2092             #
2093 4         10 foreach my $replaced_by ($instance->replaced_by()->get_set()) {
2094 0         0 print $output_file_handle "\nreplaced_by: ", $replaced_by;
2095             }
2096            
2097             #
2098             # consider
2099             #
2100 4         8 foreach my $consider ($instance->consider()->get_set()) {
2101 0         0 print $output_file_handle "\nconsider: ", $consider;
2102             }
2103            
2104             #
2105             # end
2106             #
2107 4         16 print $output_file_handle "\n";
2108             }
2109              
2110             #######################################################################
2111             #
2112             # relationship types
2113             #
2114             #######################################################################
2115 8         14 foreach my $relationship_type ( @{$self->get_relationship_types_sorted_by_id()} ) {
  8         24  
2116            
2117 89         128 print $output_file_handle "\n[Typedef]";
2118            
2119             #
2120             # id
2121             #
2122 89         181 print $output_file_handle "\nid: ", $relationship_type->id();
2123            
2124             #
2125             # is_anonymous
2126             #
2127 89 50       191 print $output_file_handle "\nis_anonymous: true" if ($relationship_type->is_anonymous());
2128            
2129             #
2130             # name
2131             #
2132 89         174 my $relationship_type_name = $relationship_type->name();
2133 89 100       153 if (defined $relationship_type_name) {
2134 81         121 print $output_file_handle "\nname: ", $relationship_type_name;
2135             }
2136            
2137             #
2138             # namespace
2139             #
2140 89         194 foreach my $ns ($relationship_type->namespace()) {
2141 0         0 print $output_file_handle "\nnamespace: ", $ns;
2142             }
2143            
2144             #
2145             # alt_id
2146             #
2147 89         210 foreach my $alt_id ($relationship_type->alt_id()->get_set()) {
2148 0         0 print $output_file_handle "\nalt_id: ", $alt_id;
2149             }
2150            
2151             #
2152             # builtin
2153             #
2154 89 100       205 print $output_file_handle "\nbuiltin: true" if ($relationship_type->builtin() == 1);
2155            
2156             #
2157             # def
2158             #
2159 89 100       222 print $output_file_handle "\ndef: ", $relationship_type->def_as_string() if (defined $relationship_type->def()->text());
2160            
2161             #
2162             # comment
2163             #
2164 89 100       223 print $output_file_handle "\ncomment: ", $relationship_type->comment() if (defined $relationship_type->comment());
2165              
2166             #
2167             # subset
2168             #
2169 89         189 foreach my $sset_name ($relationship_type->subset()) {
2170 1 50       4 if ($self->subset_def_map()->contains_key($sset_name)) {
2171 1         4 print $output_file_handle "\nsubset: ", $sset_name;
2172             } else {
2173 0         0 print $error_file_handle "\nThe relationship type ", $relationship_type->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n";
2174             }
2175             }
2176            
2177             #
2178             # synonym
2179             #
2180 89         227 foreach my $synonym ($relationship_type->synonym_set()) {
2181 12         39 print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$synonym->def()->dbxref_set_as_string();
2182             }
2183            
2184             #
2185             # xref
2186             #
2187 89     41   482 my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $relationship_type->xref_set_as_string());
  41         113  
  41         87  
2188 89         275 foreach my $xref (@sorted_xrefs) {
2189 41         92 print $output_file_handle "\nxref: ", $xref->as_string();
2190             }
2191              
2192             #
2193             # domain
2194             #
2195 89         217 foreach my $domain ($relationship_type->domain()->get_set()) {
2196 0         0 print $output_file_handle "\ndomain: ", $domain;
2197             }
2198            
2199             #
2200             # range
2201             #
2202 89         230 foreach my $range ($relationship_type->range()->get_set()) {
2203 0         0 print $output_file_handle "\nrange: ", $range;
2204             }
2205            
2206 89 100       212 print $output_file_handle "\nis_anti_symmetric: true" if ($relationship_type->is_anti_symmetric() == 1);
2207 89 50       187 print $output_file_handle "\nis_cyclic: true" if ($relationship_type->is_cyclic() == 1);
2208 89 100       161 print $output_file_handle "\nis_reflexive: true" if ($relationship_type->is_reflexive() == 1);
2209 89 100       174 print $output_file_handle "\nis_symmetric: true" if ($relationship_type->is_symmetric() == 1);
2210 89 100       173 print $output_file_handle "\nis_transitive: true" if ($relationship_type->is_transitive() == 1);
2211            
2212             #
2213             # is_a: TODO missing function to retrieve the rel types
2214             #
2215 89         168 my $rt = $self->get_relationship_type_by_id('is_a');
2216 89 50       168 if (defined $rt) {
2217 89         80 my @heads = @{$self->get_head_by_relationship_type($relationship_type, $rt)};
  89         153  
2218 89         123 foreach my $head (@heads) {
2219 32         81 my $head_name = $head->name();
2220 32 50       56 if (defined $head_name) {
2221 32         62 print $output_file_handle "\nis_a: ", $head->id(), ' ! ', $head_name;
2222             } else {
2223 0         0 print $output_file_handle "\nis_a: ", $head->id();
2224             }
2225            
2226             }
2227             }
2228            
2229             #
2230             # intersection_of (at least 2 entries)
2231             #
2232 89         217 foreach my $tr ($relationship_type->intersection_of()) {
2233 0         0 my $tr_head = $tr->head();
2234 0         0 my $tr_type = $tr->type();
2235 0         0 my $intersection_of_name = $tr_head->name();
2236 0         0 my $intersection_of_txt = "\nintersection_of: ";
2237 0 0       0 $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil');
2238 0         0 $intersection_of_txt .= $tr_head->id();
2239 0 0       0 $intersection_of_txt .= ' ! '.$intersection_of_name if (defined $intersection_of_name);
2240 0         0 print $output_file_handle $intersection_of_txt;
2241             }
2242            
2243             #
2244             # union_of (at least 2 entries)
2245             #
2246 89         209 foreach my $tr ($relationship_type->union_of()) {
2247 0         0 print $output_file_handle "\nunion_of: ", $tr;
2248             }
2249            
2250             #
2251             # disjoint_from
2252             #
2253 89         208 foreach my $disjoint_relationship_type_id ($relationship_type->disjoint_from()) {
2254 0         0 my $disjoint_from_txt = "\ndisjoint_from: ".$disjoint_relationship_type_id;
2255 0         0 my $dt = $self->get_relationship_type_by_id($disjoint_relationship_type_id);
2256 0 0       0 my $dt_name = $dt->name() if (defined $dt);
2257 0 0       0 $disjoint_from_txt .= ' ! '.$dt_name if (defined $dt_name);
2258 0         0 print $output_file_handle $disjoint_from_txt;
2259             }
2260            
2261             #
2262             # inverse_of
2263             #
2264 89         201 my $ir = $relationship_type->inverse_of();
2265 89 100       175 if (defined $ir) {
2266 16         34 my $inv_name = $ir->name();
2267 16 100       32 if (defined $inv_name) {
2268 15         36 print $output_file_handle "\ninverse_of: ", $ir->id(), ' ! ', $inv_name;
2269             } else {
2270 1         4 print $output_file_handle "\ninverse_of: ", $ir->id();
2271             }
2272             }
2273            
2274             #
2275             # transitive_over
2276             #
2277 89         189 foreach my $transitive_over ($relationship_type->transitive_over()->get_set()) {
2278 0         0 print $output_file_handle "\ntransitive_over: ", $transitive_over;
2279             }
2280            
2281             #
2282             # holds_over_chain
2283             #
2284 10         17 my @sorted_hocs = map { $_->[0] } # restore original values
  8         16  
2285 10         15 sort { $a->[1] cmp $b->[1] } # sort
2286 89         224 map { [$_, lc(@{$_}[0].@{$_}[1])] } # transform: value, sortkey
  10         10  
  10         37  
2287             $relationship_type->holds_over_chain();
2288 89         154 foreach my $holds_over_chain (@sorted_hocs) {
2289 10         17 print $output_file_handle "\nholds_over_chain: ", @{$holds_over_chain}[0], ' ', @{$holds_over_chain}[1];
  10         12  
  10         22  
2290             }
2291            
2292             #
2293             # is_functional
2294             #
2295 89 50       196 print $output_file_handle "\nis_functional: true" if ($relationship_type->is_functional() == 1);
2296            
2297             #
2298             # is_inverse_functional
2299             #
2300 89 50       175 print $output_file_handle "\nis_inverse_functional: true" if ($relationship_type->is_inverse_functional() == 1);
2301              
2302             #
2303             # created_by
2304             #
2305 89 100       176 print $output_file_handle "\ncreated_by: ", $relationship_type->created_by() if (defined $relationship_type->created_by());
2306              
2307             #
2308             # creation_date
2309             #
2310 89 100       176 print $output_file_handle "\ncreation_date: ", $relationship_type->creation_date() if (defined $relationship_type->creation_date());
2311            
2312             #
2313             # modified_by
2314             #
2315 89 50       162 print $output_file_handle "\nmodified_by: ", $relationship_type->modified_by() if (defined $relationship_type->modified_by());
2316              
2317             #
2318             # modification_date
2319             #
2320 89 50       168 print $output_file_handle "\nmodification_date: ", $relationship_type->modification_date() if (defined $relationship_type->modification_date());
2321            
2322             #
2323             # is_obsolete
2324             #
2325 89 50       163 print $output_file_handle "\nis_obsolete: true" if ($relationship_type->is_obsolete());
2326            
2327             #
2328             # replaced_by
2329             #
2330 89         181 foreach my $replaced_by ($relationship_type->replaced_by()->get_set()) {
2331 0         0 print $output_file_handle "\nreplaced_by: ", $replaced_by;
2332             }
2333            
2334             #
2335             # consider
2336             #
2337 89         253 foreach my $consider ($relationship_type->consider()->get_set()) {
2338 0         0 print $output_file_handle "\nconsider: ", $consider;
2339             }
2340            
2341             #
2342             # is_metadata_tag
2343             #
2344 89 50       205 print $output_file_handle "\nis_metadata_tag: true" if ($relationship_type->is_metadata_tag() == 1);
2345            
2346             #
2347             # is_class_level
2348             #
2349 89 50       177 print $output_file_handle "\nis_class_level: true" if ($relationship_type->is_class_level() == 1);
2350            
2351             #
2352             # the end...
2353             #
2354 89         322 print $output_file_handle "\n";
2355             }
2356             }
2357              
2358             =head2 export2rdf
2359              
2360             See - OBO::Core::Ontology::export()
2361            
2362             =cut
2363              
2364             sub export2rdf {
2365            
2366 2     2 1 4 my ($self, $output_file_handle, $error_file_handle, $base, $namespace, $rdf_tc, $skip) = @_;
2367            
2368 2 50 33     24 if ($base && $base !~ /^http/) {
    50          
2369 0         0 croak "RDF export: you must provide a valid URL, e.g. export('rdf', \*STDOUT, \*STDERR, 'http://www.cellcycleontology.org/ontology/rdf/')";
2370             } elsif (!defined $namespace) {
2371 0         0 croak "RDF export: you must provide a valid namespace (e.g. 'SSB')";
2372             }
2373              
2374 2         2 my $default_URL = $base;
2375 2         4 my $NS = uc ($namespace);
2376 2         5 my $ns = lc ($namespace);
2377            
2378             #
2379             # Preamble: namespaces
2380             #
2381 2         27 print $output_file_handle "\n";
2382 2         4 print $output_file_handle "
2383 2         3 print $output_file_handle "\txmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\n";
2384 2         3 print $output_file_handle "\txmlns:rdfs=\"http://www.w3.org/2000/01/rdf-schema#\"\n";
2385 2         6 print $output_file_handle "\txmlns:".$ns."=\"".$default_URL.$NS."#\">\n";
2386             #######################################################################
2387             #
2388             # Terms
2389             #
2390             #######################################################################
2391 2         2 my @all_terms = @{$self->get_terms_sorted_by_id()};
  2         6  
2392 2         26 foreach my $term (@all_terms) {
2393 1284         2586 my $term_id = $term->id();
2394             # vlmir - the 3 lines below make the export compatible with BFO, CCO and GenXO
2395 1284         1941 $term_id =~ tr/[_\-]//; # vlmir - trimming (needed for CCO and GenXO, does not harm anyway)
2396 1284         5164 $term_id =~ /\A(\w+):/xms; # vlmir
2397 1284 50       3215 $1 ? my $rdf_subnamespace = $1:next; # vlmir - bad ID
2398 1284         1730 $term_id =~ tr/:/_/;
2399 1284         3437 print $output_file_handle "\t<",$ns,":".$rdf_subnamespace." rdf:about=\"#".$term_id."\">\n";
2400            
2401             #
2402             # is_anonymous
2403             #
2404 1284 50       2678 print $output_file_handle "\t\t<",$ns,":is_anonymous>true\n" if ($term->is_anonymous());
2405              
2406             #
2407             # name
2408             #
2409 1284         2176 my $term_name = $term->name();
2410 1284 50       2016 my $term_name_to_print = (defined $term_name)?$term_name:'no_name';
2411 1284         2119 print $output_file_handle "\t\t".&__char_hex_http($term_name_to_print)."\n";
2412            
2413             #
2414             # alt_id
2415             #
2416 1284         2754 foreach my $alt_id ($term->alt_id()->get_set()) {
2417 9         27 print $output_file_handle "\t\t<",$ns,":hasAlternativeId>", $alt_id, "\n";
2418             }
2419            
2420             #
2421             # builtin
2422             #
2423 1284 50       2532 print $output_file_handle "\t\t<",$ns,":builtin>true\n" if ($term->builtin() == 1);
2424            
2425             #
2426             # property_value
2427             #
2428 1284         2552 my @property_values = sort {$a->id() cmp $b->id()} $term->property_value()->get_set();
  0         0  
2429 1284         1779 foreach my $value (@property_values) {
2430 0 0       0 if (defined $value->head()->instance_of()) {
2431 0         0 print $output_file_handle "\t\t<",$ns,":property_value>\n";
2432 0         0 print $output_file_handle "\t\t\t\n";
2433 0         0 print $output_file_handle "\t\t\t\t<",$ns,":property>", $value->type(),'\n";
2434 0         0 print $output_file_handle "\t\t\t\t<",$ns,":value rdf:type=\"",$value->head()->instance_of()->id(),"\">", $value->head()->id(),'\n";
2435 0         0 print $output_file_handle "\t\t\t\n";
2436 0         0 print $output_file_handle "\t\t";
2437             } else {
2438 0         0 print $output_file_handle "\t\t<",$ns,":property_value>\n";
2439 0         0 print $output_file_handle "\t\t\t\n";
2440 0         0 print $output_file_handle "\t\t\t\t<",$ns,":property>", $value->type(),'\n";
2441 0         0 print $output_file_handle "\t\t\t\t<",$ns,":value>", $value->head()->id(),'\n";
2442 0         0 print $output_file_handle "\t\t\t\n";
2443 0         0 print $output_file_handle "\t\t";
2444             }
2445             }
2446              
2447             #
2448             # def
2449             #
2450 1284 100       2270 if (defined $term->def()->text()) {
2451 789         65097 print $output_file_handle "\t\t<",$ns,":Definition>\n";
2452 789         849 print $output_file_handle "\t\t\t\n";
2453 789         1293 print $output_file_handle "\t\t\t\t<",$ns,":def>", &__char_hex_http($term->def()->text()), "\n";
2454 789         1623 for my $ref ($term->def()->dbxref_set()->get_set()) {
2455 990         1339 print $output_file_handle "\t\t\t\t<",$ns,":DbXref>\n";
2456 990         916 print $output_file_handle "\t\t\t\t\t\n";
2457 990         1890 print $output_file_handle "\t\t\t\t\t\t<",$ns,":acc>", $ref->acc(),"\n";
2458 990         2072 print $output_file_handle "\t\t\t\t\t\t<",$ns,":dbname>", $ref->db(),"\n";
2459 990         1074 print $output_file_handle "\t\t\t\t\t\n";
2460 990         1474 print $output_file_handle "\t\t\t\t\n";
2461             }
2462              
2463 789         1189 print $output_file_handle "\t\t\t\n";
2464 789         1022 print $output_file_handle "\t\t\n";
2465             }
2466            
2467             #
2468             # comment
2469             #
2470 1284 100       2542 if(defined $term->comment()){
2471 30         72 print $output_file_handle "\t\t".&__char_hex_http($term->comment())."\n";
2472             }
2473            
2474             #
2475             # subset
2476             #
2477 1284         2328 foreach my $sset_name (sort {$a cmp $b} $term->subset()) {
  0         0  
2478 0 0       0 if ($self->subset_def_map()->contains_key($sset_name)) {
2479 0         0 print $output_file_handle "\t\t<",$ns,":subset>",$sset_name,"\n";
2480             } else {
2481 0         0 print $error_file_handle "\nThe term ", $term->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n";
2482             }
2483             }
2484              
2485             #
2486             # synonym
2487             #
2488 1284         2605 foreach my $synonym ($term->synonym_set()) {
2489 1250         1473 print $output_file_handle "\t\t<",$ns,":synonym>\n";
2490 1250         1411 print $output_file_handle "\t\t\t\n";
2491              
2492 1250         2485 print $output_file_handle "\t\t\t\t<",$ns,":syn>", &__char_hex_http($synonym->def()->text()), "\n";
2493 1250         2544 print $output_file_handle "\t\t\t\t<",$ns,":scope>", $synonym->scope(),"\n";
2494              
2495 1250         2223 for my $ref ($synonym->def()->dbxref_set()->get_set()) {
2496 148         200 print $output_file_handle "\t\t\t\t<",$ns,":DbXref>\n";
2497 148         123 print $output_file_handle "\t\t\t\t\t\n";
2498 148         274 print $output_file_handle "\t\t\t\t\t\t<",$ns,":acc>", $ref->acc(),"\n";
2499 148         300 print $output_file_handle "\t\t\t\t\t\t<",$ns,":dbname>", $ref->db(),"\n";
2500 148         251 print $output_file_handle "\t\t\t\t\t\n";
2501 148         252 print $output_file_handle "\t\t\t\t\n";
2502             }
2503              
2504 1250         1765 print $output_file_handle "\t\t\t\n";
2505 1250         1808 print $output_file_handle "\t\t\n";
2506             }
2507            
2508             #
2509             # xref
2510             #
2511 1284     620   5704 my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $term->xref_set_as_string());
  620         1643  
  620         1105  
2512 1284         3385 foreach my $xref (@sorted_xrefs) {
2513 620         1068 print $output_file_handle "\t\t<",$ns,":xref>\n";
2514 620         700 print $output_file_handle "\t\t\t\n";
2515 620         1211 print $output_file_handle "\t\t\t\t<",$ns,":acc>", $xref->acc(),'\n";
2516 620         1331 print $output_file_handle "\t\t\t\t<",$ns,":dbname>", $xref->db(),'\n";
2517 620         639 print $output_file_handle "\t\t\t\n";
2518 620         906 print $output_file_handle "\t\t\n";
2519             }
2520              
2521             #
2522             # is_a
2523             #
2524 1284         2379 my $rt = $self->get_relationship_type_by_id('is_a');
2525 1284 50       1986 if (defined $rt) {
2526 1284 50       1918 print $output_file_handle "\t\t<",$ns,":is_a rdf:resource=\"#", $term_id, "\"/>\n" if ($rdf_tc); # workaround for the rdf_tc!!!
2527 1284         1006 my %saw_is_a; # avoid duplicated arrows (RelationshipSet?)
2528 1284     1512   2754 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  1512         4486  
  1284         2279  
2529 1284         5798 foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) {
2530 1512         2301 my $head_id = $head->id();
2531 1512         2421 $head_id =~ tr/:/_/;
2532 1512         4912 print $output_file_handle "\t\t<",$ns,":is_a rdf:resource=\"#", $head_id, "\"/>\n";
2533             }
2534             }
2535            
2536             #
2537             # intersection_of (at least 2 entries)
2538             #
2539 1284         2781 foreach my $tr ($term->intersection_of()) {
2540             # TODO Improve this export
2541 0         0 my $tr_head = $tr->head();
2542 0         0 my $tr_type = $tr->type();
2543 0         0 my $tr_head_id = $tr_head->id();
2544 0         0 $tr_head_id =~ tr/:/_/;
2545              
2546 0         0 my $intersection_of_txt = '';
2547 0 0       0 $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil');
2548 0         0 $intersection_of_txt .= $tr_head_id;
2549 0         0 print $output_file_handle "\t\t<",$ns,":intersection_of rdf:resource=\"#", $intersection_of_txt, "\"/>\n";
2550             }
2551            
2552             #
2553             # union_of (at least 2 entries)
2554             #
2555 1284         2707 foreach my $union_of_term_id ($term->union_of()) {
2556 0         0 $union_of_term_id =~ tr/:/_/;
2557 0         0 print $output_file_handle "\t\t<",$ns,":union_of rdf:resource=\"#", $union_of_term_id, "\"/>\n";
2558             }
2559            
2560             #
2561             # disjoint_from
2562             #
2563 1284         2731 foreach my $disjoint_term_id ($term->disjoint_from()) {
2564 4         8 $disjoint_term_id =~ tr/:/_/;
2565 4         11 print $output_file_handle "\t\t<",$ns,":disjoint_from rdf:resource=\"#", $disjoint_term_id, "\"/>\n";
2566             }
2567              
2568             #
2569             # relationship
2570             #
2571 1284         1279 foreach my $rt ( @{$self->get_relationship_types_sorted_by_id()} ) {
  1284         2049  
2572 14951         24911 my $rt_name = $rt->name();
2573 14951 100 100     45347 if ($rt_name && $rt_name ne 'is_a') { # is_a is printed above
2574 13667         14717 my $rt_name_clean = __get_name_without_whitespaces($rt_name);
2575 13667 50 33     22309 print $output_file_handle "\t\t<",$ns,":", $rt_name_clean, " rdf:resource=\"#", $term_id, "\"/>\n" if ($rdf_tc && $rt_name_clean eq 'part_of'); # workaround for the rdf_tc!!!
2576 13667         8881 my %saw_rel; # avoid duplicated arrows (RelationshipSet?)
2577 13667     514   25988 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  514         1463  
  13667         17783  
2578 13667         36399 foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) {
2579 514         835 my $head_id = $head->id();
2580 514         825 $head_id =~ tr/:/_/;
2581 514         2154 print $output_file_handle "\t\t<",$ns,":", $rt_name_clean," rdf:resource=\"#", $head_id, "\"/>\n";
2582             }
2583             }
2584             }
2585            
2586             #
2587             # created_by
2588             #
2589 1284 50       5183 print $output_file_handle "\t\t<",$ns,':created_by>', $term->created_by(), '\n" if (defined $term->created_by());
2590              
2591             #
2592             # creation_date
2593             #
2594 1284 50       2196 print $output_file_handle "\t\t<",$ns,':creation_date>', $term->creation_date(), '\n" if (defined $term->creation_date());
2595            
2596             #
2597             # modified_by
2598             #
2599 1284 50       2201 print $output_file_handle "\t\t<",$ns,':modified_by>', $term->modified_by(), '\n" if (defined $term->modified_by());
2600              
2601             #
2602             # modification_date
2603             #
2604 1284 50       2057 print $output_file_handle "\t\t<",$ns,':modification_date>', $term->modification_date(), '\n" if (defined $term->modification_date());
2605            
2606             #
2607             # is_obsolete
2608             #
2609 1284 100       2494 print $output_file_handle "\t\t<",$ns,':is_obsolete>true\n" if ($term->is_obsolete() == 1);
2610            
2611             #
2612             # replaced_by
2613             #
2614 1284         2217 foreach my $replaced_by ($term->replaced_by()->get_set()) {
2615 0         0 print $output_file_handle "\t\t<",$ns,':replaced_by>', $replaced_by, '\n";
2616             }
2617            
2618             #
2619             # consider
2620             #
2621 1284         2561 foreach my $consider ($term->consider()->get_set()) {
2622 0         0 print $output_file_handle "\t\t<",$ns,':consider>', $consider, '\n";
2623             }
2624            
2625             #
2626             # end of term
2627             #
2628 1284         5518 print $output_file_handle "\t\n";
2629             }
2630              
2631             #######################################################################
2632             #
2633             # instances
2634             #
2635             #######################################################################
2636 2         6 my @all_instances = @{$self->get_instances_sorted_by_id()};
  2         10  
2637 2         5 foreach my $instance (@all_instances) {
2638             # TODO export instances
2639             }
2640            
2641             #######################################################################
2642             #
2643             # relationship types
2644             #
2645             #######################################################################
2646 2 50       7 unless ($skip) { # for integration processes and using biometarel for example.
2647 2         4 my @all_relationship_types = sort values(%{$self->{RELATIONSHIP_TYPES}});
  2         76  
2648 2         5 foreach my $relationship_type (@all_relationship_types) {
2649 33         62 my $relationship_type_id = $relationship_type->id();
2650 33         54 $relationship_type_id =~ tr/:/_/;
2651 33         113 print $output_file_handle "\t<",$ns,":rel_type rdf:about=\"#".$relationship_type_id."\">\n";
2652            
2653             #
2654             # is_anonymous
2655             #
2656 33 50       64 print $output_file_handle "\t\t<",$ns,':is_anonymous>true\n" if ($relationship_type->is_anonymous());
2657              
2658             #
2659             # namespace
2660             #
2661 33         63 foreach my $nspace ($relationship_type->namespace()) {
2662 0         0 print $output_file_handle "\t\t<",$ns,':namespace>', $nspace, '\n";
2663             }
2664            
2665             #
2666             # alt_id
2667             #
2668 33         70 foreach my $alt_id ($relationship_type->alt_id()->get_set()) {
2669 0         0 print $output_file_handle "\t\t<",$ns,':alt_id>', $alt_id, '\n";
2670             }
2671            
2672             #
2673             # builtin
2674             #
2675 33 100       67 print $output_file_handle "\t\t<",$ns,':builtin>true\n" if ($relationship_type->builtin() == 1);
2676            
2677             #
2678             # name
2679             #
2680 33 100       60 if (defined $relationship_type->name()) {
2681 32         52 print $output_file_handle "\t\t".&__char_hex_http($relationship_type->name())."\n";
2682             } else {
2683 1         4 print $output_file_handle "\t\n"; # close the relationship type tag! (skipping the rest of the data, contact those guys)
2684 1         4 next;
2685             }
2686            
2687             #
2688             # def
2689             #
2690 32 100       71 if (defined $relationship_type->def()->text()) {
2691 21         27 print $output_file_handle "\t\t<",$ns,":Definition>\n";
2692 21         21 print $output_file_handle "\t\t\t\n";
2693 21         44 print $output_file_handle "\t\t\t\t<",$ns,':def>', &__char_hex_http($relationship_type->def()->text()), "\n";
2694 21         45 for my $ref ($relationship_type->def()->dbxref_set()->get_set()) {
2695 20         51 print $output_file_handle "\t\t\t\t<",$ns,":DbXref>\n";
2696 20         18 print $output_file_handle "\t\t\t\t\t\n";
2697 20         37 print $output_file_handle "\t\t\t\t\t\t<",$ns,':acc>', $ref->acc(),'\n";
2698 20         59 print $output_file_handle "\t\t\t\t\t\t<",$ns,':dbname>', $ref->db(),'\n";
2699 20         22 print $output_file_handle "\t\t\t\t\t\n";
2700 20         31 print $output_file_handle "\t\t\t\t\n";
2701             }
2702              
2703 21         25 print $output_file_handle "\t\t\t\n";
2704 21         20 print $output_file_handle "\t\t\n";
2705             }
2706              
2707             #
2708             # comment
2709             #
2710 32 100       80 if(defined $relationship_type->comment()){
2711 12         16 print $output_file_handle "\t\t".&__char_hex_http($relationship_type->comment())."\n";
2712             }
2713            
2714             #
2715             # subset
2716             #
2717 32         67 foreach my $sset_name ($relationship_type->subset()) {
2718 0 0       0 if ($self->subset_def_map()->contains_key($sset_name)) {
2719 0         0 print $output_file_handle "\t\t<",$ns,":subset>",$sset_name,"\n";
2720             } else {
2721 0         0 print $error_file_handle "\nThe relationship type ", $relationship_type->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n";
2722             }
2723             }
2724            
2725             #
2726             # synonym
2727             #
2728 32         69 foreach my $synonym ($relationship_type->synonym_set()) {
2729 6         8 print $output_file_handle "\t\t<",$ns,":synonym>\n";
2730 6         11 print $output_file_handle "\t\t\t\n";
2731              
2732 6         17 print $output_file_handle "\t\t\t\t<",$ns,':syn>', &__char_hex_http($synonym->def()->text()), "\n";
2733 6         13 print $output_file_handle "\t\t\t\t<",$ns,':scope>', $synonym->scope(),'\n";
2734              
2735 6         11 for my $ref ($synonym->def()->dbxref_set()->get_set()) {
2736 2         4 print $output_file_handle "\t\t\t\t<",$ns,":DbXref>\n";
2737 2         3 print $output_file_handle "\t\t\t\t\t\n";
2738 2         5 print $output_file_handle "\t\t\t\t\t\t<",$ns,':acc>', $ref->acc(),'\n";
2739 2         6 print $output_file_handle "\t\t\t\t\t\t<",$ns,':dbname>', $ref->db(),'\n";
2740 2         4 print $output_file_handle "\t\t\t\t\t\n";
2741 2         2 print $output_file_handle "\t\t\t\t\n";
2742             }
2743              
2744 6         10 print $output_file_handle "\t\t\t\n";
2745 6         8 print $output_file_handle "\t\t\n";
2746             }
2747              
2748             #
2749             # xref
2750             #
2751 32     32   159 my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $relationship_type->xref_set_as_string());
  32         75  
  32         65  
2752 32         82 foreach my $xref (@sorted_xrefs) {
2753 32         48 print $output_file_handle "\t\t<",$ns,":xref>\n";
2754 32         28 print $output_file_handle "\t\t\t\n";
2755 32         62 print $output_file_handle "\t\t\t\t<",$ns,':acc>', $xref->acc(),'\n";
2756 32         64 print $output_file_handle "\t\t\t\t<",$ns,':dbname>', $xref->db(),'\n";
2757 32         65 print $output_file_handle "\t\t\t\n";
2758 32         52 print $output_file_handle "\t\t\n";
2759             }
2760              
2761             #
2762             # domain
2763             #
2764 32         65 foreach my $domain ($relationship_type->domain()->get_set()) {
2765 0         0 print $output_file_handle "\t\t<",$ns,':domain>', $domain, '\n";
2766             }
2767            
2768             #
2769             # range
2770             #
2771 32         80 foreach my $range ($relationship_type->range()->get_set()) {
2772 0         0 print $output_file_handle "\t\t<",$ns,':range>', $range, '\n";
2773             }
2774              
2775 32 100       78 print $output_file_handle "\t\t<",$ns,':is_anti_symmetric>true\n" if ($relationship_type->is_anti_symmetric() == 1);
2776 32 50       61 print $output_file_handle "\t\t<",$ns,':is_cyclic>true\n" if ($relationship_type->is_cyclic() == 1);
2777 32 100       56 print $output_file_handle "\t\t<",$ns,':is_reflexive>true\n" if ($relationship_type->is_reflexive() == 1);
2778 32 100       165 print $output_file_handle "\t\t<",$ns,':is_symmetric>true\n" if ($relationship_type->is_symmetric() == 1);
2779 32 100       55 print $output_file_handle "\t\t<",$ns,':is_transitive>true\n" if ($relationship_type->is_transitive() == 1);
2780              
2781             #
2782             # is_a
2783             #
2784 32         53 my $rt = $self->get_relationship_type_by_id('is_a');
2785 32 50       51 if (defined $rt) {
2786 32         26 my @heads = @{$self->get_head_by_relationship_type($relationship_type, $rt)};
  32         43  
2787 32         42 foreach my $head (@heads) {
2788 29         45 my $head_id = $head->id();
2789 29         45 $head_id =~ tr/:/_/;
2790 29         69 print $output_file_handle "\t\t<",$ns,":is_a rdf:resource=\"#", $head_id, "\"/>\n";
2791             }
2792             }
2793            
2794             #
2795             # intersection_of (at least 2 entries)
2796             #
2797 32         73 foreach my $tr ($relationship_type->intersection_of()) {
2798             # TODO Improve this export
2799 0         0 my $tr_head = $tr->head();
2800 0         0 my $tr_type = $tr->type();
2801 0         0 my $tr_head_id = $tr_head->id();
2802 0         0 $tr_head_id =~ tr/:/_/;
2803              
2804 0         0 my $intersection_of_txt = "";
2805 0 0       0 $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil');
2806 0         0 $intersection_of_txt .= $tr_head_id;
2807 0         0 print $output_file_handle "\t\t<",$ns,":intersection_of rdf:resource=\"#", $intersection_of_txt, "\"/>\n";
2808             }
2809            
2810             #
2811             # union_of (at least 2 entries)
2812             #
2813 32         66 foreach my $union_of_rt_id ($relationship_type->union_of()) {
2814 0         0 $union_of_rt_id =~ tr/:/_/;
2815 0         0 print $output_file_handle "\t\t<",$ns,":union_of rdf:resource=\"#", $union_of_rt_id, "\"/>\n";
2816             }
2817            
2818             #
2819             # disjoint_from
2820             #
2821 32         67 foreach my $df ($relationship_type->disjoint_from()) {
2822 0         0 print $output_file_handle "\t\t<",$ns,":disjoint_from rdf:resource=\"#", $df, "\"/>\n";
2823             }
2824              
2825             #
2826             # inverse_of
2827             #
2828 32         60 my $ir = $relationship_type->inverse_of();
2829 32 50       52 if (defined $ir) {
2830 0         0 print $output_file_handle "\t\t<",$ns,":inverse_of rdf:resource=\"#", $ir->id(), "\"/>\n";
2831             }
2832            
2833             #
2834             # transitive_over
2835             #
2836 32         65 foreach my $transitive_over ($relationship_type->transitive_over()->get_set()) {
2837 0         0 print $output_file_handle "\t\t<",$ns,':transitive_over>', $transitive_over, '\n";
2838             }
2839            
2840             #
2841             # holds_over_chain
2842             #
2843 32         63 foreach my $holds_over_chain ($relationship_type->holds_over_chain()) {
2844 0         0 print $output_file_handle "\t\t<",$ns,":holds_over_chain>\n";
2845 0         0 print $output_file_handle "\t\t\t<",$ns,':r1>', @{$holds_over_chain}[0], '\n";
  0         0  
2846 0         0 print $output_file_handle "\t\t\t<",$ns,':r2>', @{$holds_over_chain}[1], '\n";
  0         0  
2847 0         0 print $output_file_handle "\t\t<",$ns,":/holds_over_chain>\n";
2848             }
2849              
2850             #
2851             # is_functional
2852             #
2853 32 50       89 print $output_file_handle "\t\t<",$ns,':is_functional>true\n" if ($relationship_type->is_functional() == 1);
2854            
2855             #
2856             # is_inverse_functional
2857             #
2858 32 50       55 print $output_file_handle "\t\t<",$ns,':is_inverse_functional>true\n" if ($relationship_type->is_inverse_functional() == 1);
2859            
2860             #
2861             # created_by
2862             #
2863 32 50       65 print $output_file_handle "\t\t<",$ns,':created_by>', $relationship_type->created_by(), '\n" if (defined $relationship_type->created_by());
2864              
2865             #
2866             # creation_date
2867             #
2868 32 50       56 print $output_file_handle "\t\t<",$ns,':creation_date>', $relationship_type->creation_date(), '\n" if (defined $relationship_type->creation_date());
2869            
2870             #
2871             # modified_by
2872             #
2873 32 50       51 print $output_file_handle "\t\t<",$ns,':modified_by>', $relationship_type->modified_by(), '\n" if (defined $relationship_type->modified_by());
2874              
2875             #
2876             # modification_date
2877             #
2878 32 50       57 print $output_file_handle "\t\t<",$ns,':modification_date>', $relationship_type->modification_date(), "\n" if (defined $relationship_type->modification_date());
2879            
2880             #
2881             # is_obsolete
2882             #
2883 32 50       58 print $output_file_handle "\t\t<",$ns,':is_obsolete>true\n" if ($relationship_type->is_obsolete() == 1);
2884            
2885             #
2886             # replaced_by
2887             #
2888 32         57 foreach my $replaced_by ($relationship_type->replaced_by()->get_set()) {
2889 0         0 print $output_file_handle "\t\t<",$ns,':replaced_by>', $replaced_by, '\n";
2890             }
2891            
2892             #
2893             # consider
2894             #
2895 32         65 foreach my $consider ($relationship_type->consider()->get_set()) {
2896 0         0 print $output_file_handle "\t\t<",$ns,':consider>', $consider, '\n";
2897             }
2898            
2899             #
2900             # is_metadata_tag
2901             #
2902 32 50       67 print $output_file_handle "\t\t<",$ns,':is_metadata_tag>true\n" if ($relationship_type->is_metadata_tag() == 1);
2903            
2904             #
2905             # is_class_level
2906             #
2907 32 50       50 print $output_file_handle "\t\t<",$ns,':is_class_level>true\n" if ($relationship_type->is_class_level() == 1);
2908            
2909             #
2910             # end of relationship type
2911             #
2912 32         76 print $output_file_handle "\t\n";
2913             }
2914             }
2915            
2916             #
2917             # EOF:
2918             #
2919 2         5 print $output_file_handle "\n\n";
2920 2         16 print $output_file_handle "";
2921             }
2922              
2923             =head2 export2owl
2924              
2925             See - OBO::Core::Ontology::export()
2926            
2927             =cut
2928              
2929             sub export2owl {
2930            
2931 2     2 1 5 my ($self, $output_file_handle, $error_file_handle, $oboContentUrl, $oboInOwlUrl) = @_;
2932            
2933 2 50       17 if ($oboContentUrl !~ /^http/) {
2934 0         0 croak "OWL export: you must provide a valid URL, e.g. export('owl', \*STDOUT, \*STDERR, 'http://www.cellcycleontology.org/ontology/owl/')";
2935             }
2936            
2937 2 50       8 if ($oboInOwlUrl !~ /^http/) {
2938 0         0 ( $oboInOwlUrl = $oboContentUrl ) =~ s{/\w+/owl/\z}{/formats/oboInOwl#}xms;
2939 0         0 warn "Using a default URI for OboInOwl '$oboInOwlUrl' ";
2940             }
2941              
2942             #
2943             # preambule
2944             #
2945 2         16 print $output_file_handle '' ."\n";
2946 2         4 print $output_file_handle '
2947 2         6 print $output_file_handle "\t".'xmlns="'.$oboContentUrl.'"' ."\n";
2948 2         4 print $output_file_handle "\t".'xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"' ."\n";
2949 2         4 print $output_file_handle "\t".'xmlns:rdfs="http://www.w3.org/2000/01/rdf-schema#"' ."\n";
2950 2         3 print $output_file_handle "\t".'xmlns:owl="http://www.w3.org/2002/07/owl#"' ."\n";
2951 2         3 print $output_file_handle "\t".'xmlns:xsd="http://www.w3.org/2001/XMLSchema#"' ."\n";
2952 2         6 print $output_file_handle "\t".'xmlns:oboInOwl="'.$oboInOwlUrl.'"' ."\n";
2953 2         5 print $output_file_handle "\t".'xmlns:oboContent="'.$oboContentUrl.'"' ."\n";
2954            
2955 2   33     9 my $ontology_id_space = $self->id() || $self->get_terms_idspace();
2956 2         18 print $output_file_handle "\t".'xml:base="'.$oboContentUrl.$ontology_id_space.'"' ."\n";
2957              
2958             #print $output_file_handle "\txmlns:p1=\"http://protege.stanford.edu/plugins/owl/dc/protege-dc.owl#\"\n";
2959             #print $output_file_handle "\txmlns:dcterms=\"http://purl.org/dc/terms/\"\n";
2960             #print $output_file_handle "\txmlns:xsp=\"http://www.owl-ontologies.com/2005/08/07/xsp.owl#\"\n";
2961             #print $output_file_handle "\txmlns:dc=\"http://purl.org/dc/elements/1.1/\"\n";
2962            
2963 2         4 print $output_file_handle '>'."\n"; # rdf:RDF
2964              
2965             #
2966             # meta-data: oboInOwl elements
2967             #
2968 2         7 foreach my $ap ('hasURI', 'hasAlternativeId', 'hasDate', 'hasVersion', 'hasDbXref', 'hasDefaultNamespace', 'hasNamespace', 'hasDefinition', 'hasExactSynonym', 'hasNarrowSynonym', 'hasBroadSynonym', 'hasRelatedSynonym', 'hasSynonymType', 'hasSubset', 'inSubset', 'savedBy', 'replacedBy', 'consider') {
2969 36         45 print $output_file_handle "\n";
2970             }
2971 2         4 foreach my $c ('DbXref', 'Definition', 'Subset', 'Synonym', 'SynonymType', 'ObsoleteClass') {
2972 12         24 print $output_file_handle "\n";
2973             }
2974 2         7 print $output_file_handle "\n";
2975 2         5 print $output_file_handle "\n";
2976              
2977             #
2978             # header: http://oe0.spreadsheets.google.com/ccc?id=o06770842196506107736.4732937099693365844.03735622766900057712.3276521997699206495#
2979             #
2980 2         4 print $output_file_handle "\n";
2981 2         9 foreach my $import_obo ($self->imports()->get_set()) {
2982             # As Ontology.pm is independant of the format (OBO, OWL) it will import the ID of the ontology
2983 0         0 (my $import_owl = $import_obo) =~ s/\.obo/\.owl/;
2984 0         0 print $output_file_handle "\t\n";
2985             }
2986             # format-version is not treated
2987 2 50       8 print $output_file_handle "\t", $self->date(), "\n" if ($self->date());
2988 2 50       8 print $output_file_handle "\t", $self->data_version(), "\n" if ($self->data_version());
2989 2 50       6 print $output_file_handle '\t\t', $self->id(), "\n" if ($self->id());
2990 2 100       7 print $output_file_handle "\t", $self->saved_by(), "\n" if ($self->saved_by());
2991             #print $output_file_handle "\tautogenerated-by: ", $0, "\n";
2992 2 50       8 print $output_file_handle "\t", $self->default_relationship_id_prefix(), "\n" if ($self->default_relationship_id_prefix());
2993 2 50       6 print $output_file_handle "\t", $self->default_namespace(), "\n" if ($self->default_namespace());
2994 2         5 foreach my $remark ($self->remarks()->get_set()) {
2995 2         7 print $output_file_handle "\t", $remark, "\n";
2996             }
2997            
2998             # treat-xrefs-as-equivalent
2999 2         7 foreach my $id_space_xref_eq (sort {lc($a) cmp lc($b)} $self->treat_xrefs_as_equivalent()->get_set()) {
  0         0  
3000 0         0 print $output_file_handle '\t\t', $id_space_xref_eq, "\n";
3001             }
3002            
3003             # treat_xrefs_as_is_a
3004 2         7 foreach my $id_space_xref_eq (sort {lc($a) cmp lc($b)} $self->treat_xrefs_as_is_a()->get_set()) {
  0         0  
3005 0         0 print $output_file_handle '\t\t', $id_space_xref_eq, "\n";
3006             }
3007            
3008             # subsetdef
3009 2         6 foreach my $subsetdef (sort {lc($a->name()) cmp lc($b->name())} $self->subset_def_map()->values()) {
  0         0  
3010 0         0 print $output_file_handle "\t\n";
3011 0         0 print $output_file_handle "\t\tname(), "\">\n";
3012 0         0 print $output_file_handle "\t\t\t", $subsetdef->description(), "\n";
3013 0         0 print $output_file_handle "\t\t\n";
3014 0         0 print $output_file_handle "\t\n";
3015             }
3016            
3017             # synonyntypedef
3018 2         16 foreach my $st ($self->synonym_type_def_set()->get_set()) {
3019 0         0 print $output_file_handle "\t\n";
3020 0         0 print $output_file_handle "\t\tname(), "\">\n";
3021 0         0 print $output_file_handle "\t\t\t", $st->description(), "\n";
3022 0         0 my $scope = $st->scope();
3023 0 0       0 print $output_file_handle "\t\t\t", $scope, "\n" if (defined $scope);
3024 0         0 print $output_file_handle "\t\t\n";
3025 0         0 print $output_file_handle "\t\n";
3026             }
3027            
3028             # idspace
3029 2         7 my $ids = $self->idspaces()->get_set();
3030 2         3 my $local_idspace = undef;
3031 2 50       45 if (defined $ids) {
3032 0         0 $local_idspace = $ids->local_idspace();
3033 0 0       0 if ($local_idspace) {
3034 0         0 print $output_file_handle "\t\n";
3035 0         0 print $output_file_handle "\t\t\n";
3036 0         0 print $output_file_handle "\t\t\t", $local_idspace, "\n";
3037 0         0 print $output_file_handle "\t\t\n";
3038 0         0 print $output_file_handle "\t\t\n";
3039 0         0 print $output_file_handle "\t\t\t", $self->idspace()->uri(), "\n";
3040 0         0 print $output_file_handle "\t\t\n";
3041 0         0 my $desc = $ids->description();
3042 0         0 print $output_file_handle "\t\t", $desc, "\n";
3043 0         0 print $output_file_handle "\t\n";
3044             }
3045             }
3046            
3047             # Ontology end tag
3048 2         5 print $output_file_handle "\n\n";
3049            
3050             #######################################################################
3051             #
3052             # term
3053             #
3054             #######################################################################
3055 2         4 my @all_terms = @{$self->get_terms_sorted_by_id()};
  2         5  
3056             # visit the terms
3057 2         31 foreach my $term (@all_terms){
3058            
3059             # for the URLs
3060 647         1531 my $term_id = $term->id();
3061 647   66     1261 $local_idspace = $local_idspace || (split(':', $term_id))[0]; # the idspace or the space from the term itself. e.g. APO
3062            
3063             #
3064             # Class name
3065             #
3066 647         1185 print $output_file_handle "\n";
3067            
3068             #
3069             # label name = class name
3070             #
3071 647 50       1291 print $output_file_handle "\t", &__char_hex_http($term->name()), "\n" if ($term->name());
3072            
3073             #
3074             # comment
3075             #
3076 647 100       1428 print $output_file_handle "\t", $term->comment(), "\n" if ($term->comment());
3077            
3078             #
3079             # subset
3080             #
3081 647         1202 foreach my $sset_name (sort {$a cmp $b} $term->subset()) {
  0         0  
3082 0 0       0 if ($self->subset_def_map()->contains_key($sset_name)) {
3083 0         0 print $output_file_handle "\t\n";
3084             } else {
3085 0         0 print $error_file_handle "\nThe term ", $term->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n";
3086             }
3087             }
3088            
3089             #
3090             # Def
3091             #
3092 647 100       1443 if (defined $term->def()->text()) {
3093 490         739 print $output_file_handle "\t\n";
3094 490         655 print $output_file_handle "\t\t\n";
3095 490         864 print $output_file_handle "\t\t\t", &__char_hex_http($term->def()->text()), "\n";
3096            
3097 490         967 __print_hasDbXref_for_owl($output_file_handle, $term->def()->dbxref_set(), $oboContentUrl, 3);
3098            
3099 490         792 print $output_file_handle "\t\t\n";
3100 490         610 print $output_file_handle "\t\n";
3101             }
3102            
3103             #
3104             # synonym:
3105             #
3106 647         1466 foreach my $synonym ($term->synonym_set()) {
3107 808         1693 my $st = $synonym->scope();
3108 808         669 my $synonym_type;
3109 808 100       1340 if ($st eq 'EXACT') {
    100          
    100          
    50          
3110 699         609 $synonym_type = 'hasExactSynonym';
3111             } elsif ($st eq 'BROAD') {
3112 14         19 $synonym_type = 'hasBroadSynonym';
3113             } elsif ($st eq 'NARROW') {
3114 72         67 $synonym_type = 'hasNarrowSynonym';
3115             } elsif ($st eq 'RELATED') {
3116 23         32 $synonym_type = 'hasRelatedSynonym';
3117             } else {
3118             # TODO Consider the synonym types defined in the header: 'synonymtypedef' tag
3119 0         0 croak 'A non-valid synonym type has been found ($synonym). Valid types: EXACT, BROAD, NARROW, RELATED';
3120             }
3121 808         1140 print $output_file_handle "\t\n";
3122 808         635 print $output_file_handle "\t\t\n";
3123 808         1382 print $output_file_handle "\t\t\t", $synonym->def()->text(), "\n";
3124            
3125 808         1298 __print_hasDbXref_for_owl($output_file_handle, $synonym->def()->dbxref_set(), $oboContentUrl, 3);
3126            
3127 808         1341 print $output_file_handle "\t\t\n";
3128 808         1316 print $output_file_handle "\t\n";
3129             }
3130            
3131             #
3132             # namespace
3133             #
3134 647         1593 foreach my $ns ($term->namespace()) {
3135 0         0 print $output_file_handle "\t", $ns, "\n";
3136             }
3137              
3138             #
3139             # alt_id:
3140             #
3141 647         1341 foreach my $alt_id ($term->alt_id()->get_set()) {
3142 0         0 print $output_file_handle "\t", $alt_id, "\n";
3143             }
3144              
3145             #
3146             # xref's
3147             #
3148 647         1421 __print_hasDbXref_for_owl($output_file_handle, $term->xref_set(), $oboContentUrl, 1);
3149            
3150             #
3151             # is_a:
3152             #
3153             # my @disjoint_term = (); # for collecting the disjoint terms of the running term
3154 647         1477 my $rt = $self->get_relationship_type_by_id('is_a');
3155 647 50       1097 if (defined $rt) {
3156 647         637 my %saw_is_a; # avoid duplicated arrows (RelationshipSet?)
3157 647     560   1498 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  560         1783  
  647         1093  
3158 647         2805 foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) {
3159 560         1161 print $output_file_handle "\tid()), "\"/>\n"; # head->name() not used
3160            
3161             # #
3162             # # Gathering for the Disjointness (see below, after the bucle)
3163             # #
3164             # # my $child_rels = $graph->get_child_relationships($rel->object_acc);
3165             # # foreach my $r (@{$child_rels}){
3166             # # if ($r->scope eq 'is_a') { # Only consider the children playing a role in the is_a realtionship
3167             # # my $already_in_array = grep /$r->subject_acc/, @disjoint_term;
3168             # # push @disjoint_term, $r->subject_acc if (!$already_in_array && $r->subject_acc ne $rel->subject_acc());
3169             # # }
3170             # # }
3171              
3172             }
3173             # #
3174             # # Disjointness (array filled up while treating the is_a relation)
3175             # #
3176             # # foreach my $disjoint (@disjoint_term){
3177             # # $disjoint =~ tr/:/_/;
3178             # # print $output_file_handle "\t\n";
3179             # # }
3180             }
3181             #
3182             # intersection_of
3183             #
3184 647         1431 my @intersection_of = $term->intersection_of();
3185 647 50       1316 if (@intersection_of) {
3186 0         0 print $output_file_handle "\t\n";
3187 0         0 print $output_file_handle "\t\t\n";
3188 0         0 print $output_file_handle "\t\t\t\n";
3189 0         0 foreach my $tr (@intersection_of) {
3190             # TODO Improve the parsing of the 'interection_of' elements
3191 0         0 my @inter = split(/\s+/, $tr);
3192             # TODO Check the idspace of the terms in the set 'intersection_of' and optimize the code: only one call to $self->idspace()->local_idspace()
3193 0 0       0 my $idspace = ($tr =~ /([A-Z]+):/)?$1:$local_idspace;
3194 0 0       0 if (scalar @inter == 1) {
    0          
3195 0 0       0 my $idspace = ($tr =~ /([A-Z]+):/)?$1:$local_idspace;
3196 0         0 print $output_file_handle "\t\t\t\n";
3197             } elsif (scalar @inter == 2) { # restriction
3198 0         0 print $output_file_handle "\t\t\n";
3199 0         0 print $output_file_handle "\t\t\t\n";
3200 0         0 print $output_file_handle "\t\t\t\t\n";
3201 0         0 print $output_file_handle "\t\t\t\n";
3202 0         0 print $output_file_handle "\t\t\t\n";
3203 0         0 print $output_file_handle "\t\t\n";
3204             } else {
3205 0         0 croak "Parsing error: 'intersection_of' tag has an unknown argument";
3206             }
3207             }
3208 0         0 print $output_file_handle "\t\t\t\n";
3209 0         0 print $output_file_handle "\t\t\n";
3210 0         0 print $output_file_handle "\t\n";
3211             }
3212            
3213             #
3214             # union_of
3215             #
3216 647         1277 my @union_of = $term->union_of();
3217 647 50       1199 if (@union_of) {
3218 0         0 print $output_file_handle "\t\n";
3219 0         0 print $output_file_handle "\t\t\n";
3220 0         0 print $output_file_handle "\t\t\t\n";
3221 0         0 foreach my $tr (@union_of) {
3222             # TODO Check the idspace of the terms in the set 'union_of'
3223 0 0       0 my $idspace = ($tr =~ /([A-Z]+):/)?$1:$local_idspace;
3224 0         0 print $output_file_handle "\t\t\t\n";
3225             }
3226 0         0 print $output_file_handle "\t\t\t\n";
3227 0         0 print $output_file_handle "\t\t\n";
3228 0         0 print $output_file_handle "\t\n";
3229             }
3230            
3231             #
3232             # disjoint_from:
3233             #
3234 647         1197 foreach my $disjoint_term_id ($term->disjoint_from()) {
3235 8         15 print $output_file_handle "\t\n";
3236             }
3237            
3238             #
3239             # relationships:
3240             #
3241 647         731 foreach $rt ( @{$self->get_relationship_types_sorted_by_id()} ) {
  647         1065  
3242 19091 100       29543 if ($rt->id() ne 'is_a') { # is_a is printed above
3243 18444         11924 my %saw_rel; # avoid duplicated arrows (RelationshipSet?)
3244 18444     370   30580 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  370         1184  
  18444         22618  
3245 18444         43793 foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) {
3246 370         946 print $output_file_handle "\t\n";
3247 370         549 print $output_file_handle "\t\t\n";
3248 370         328 print $output_file_handle "\t\t\t\n";
3249 370         783 print $output_file_handle "\t\t\t\tid(), "\"/>\n";
3250 370         460 print $output_file_handle "\t\t\t\n";
3251 370         727 print $output_file_handle "\t\t\tid()), "\"/>\n"; # head->name() not used
3252 370         483 print $output_file_handle "\t\t\n";
3253 370         789 print $output_file_handle "\t\n";
3254             }
3255             }
3256             }
3257            
3258             #
3259             # obsolete
3260             #
3261 647 50       3438 print $output_file_handle "\t\n" if ($term->is_obsolete());
3262            
3263             #
3264             # builtin:
3265             #
3266             #### Not used in OWL.####
3267            
3268             #
3269             # replaced_by
3270             #
3271 647         1183 foreach my $replaced_by ($term->replaced_by()->get_set()) {
3272 0         0 print $output_file_handle "\t\n";
3273             }
3274            
3275             #
3276             # consider
3277             #
3278 647         1464 foreach my $consider ($term->consider()->get_set()) {
3279 0         0 print $output_file_handle "\t\n";
3280             }
3281              
3282             #
3283             # End of the term
3284             #
3285 647         1978 print $output_file_handle "\n\n";
3286             }
3287            
3288             #
3289             # relationship types: properties
3290             #
3291             # TODO
3292             # print $output_file_handle "\n";
3293             # print $output_file_handle "\tpart of\n";
3294             # print $output_file_handle "\t", $self->default_namespace(), "\n" if ($self->default_namespace());
3295             # print $output_file_handle "\n";
3296            
3297 2         5 foreach my $relationship_type ( @{$self->get_relationship_types_sorted_by_id()} ) {
  2         4  
3298              
3299 31         59 my $relationship_type_id = $relationship_type->id();
3300              
3301 31 100       61 next if ($relationship_type_id eq 'is_a'); # rdfs:subClassOf covers this property (relationship)
3302            
3303             #
3304             # Object property
3305             #
3306 29         50 print $output_file_handle "\n";
3307            
3308             #
3309             # name:
3310             #
3311 29         48 my $relationship_type_name = $relationship_type->name();
3312 29 50       46 if (defined $relationship_type_name) {
3313 29         35 print $output_file_handle "\t", $relationship_type_name, "\n";
3314             }
3315            
3316             #
3317             # comment:
3318             #
3319 29 100       59 print $output_file_handle "\t", $relationship_type->comment(), "\n" if ($relationship_type->comment());
3320            
3321             #
3322             # Def:
3323             #
3324 29 100       60 if (defined $relationship_type->def()->text()) {
3325 19         20 print $output_file_handle "\t\n";
3326 19         16 print $output_file_handle "\t\t\n";
3327 19         27 print $output_file_handle "\t\t\t", &__char_hex_http($relationship_type->def()->text()), "\n";
3328            
3329 19         39 __print_hasDbXref_for_owl($output_file_handle, $relationship_type->def()->dbxref_set(), $oboContentUrl, 3);
3330            
3331 19         30 print $output_file_handle "\t\t\n";
3332 19         19 print $output_file_handle "\t\n";
3333             }
3334            
3335             #
3336             # Synonym:
3337             #
3338 29         73 foreach my $synonym ($relationship_type->synonym_set()) {
3339 3         8 my $st = $synonym->scope();
3340 3         4 my $synonym_type;
3341 3 50       6 if ($st eq 'EXACT') {
    0          
    0          
    0          
3342 3         4 $synonym_type = 'hasExactSynonym';
3343             } elsif ($st eq 'BROAD') {
3344 0         0 $synonym_type = 'hasBroadSynonym';
3345             } elsif ($st eq 'NARROW') {
3346 0         0 $synonym_type = 'hasNarrowSynonym';
3347             } elsif ($st eq 'RELATED') {
3348 0         0 $synonym_type = 'hasRelatedSynonym';
3349             } else {
3350             # TODO Consider the synonym types defined in the header: 'synonymtypedef' tag
3351 0         0 croak 'A non-valid synonym type has been found ($synonym). Valid types: EXACT, BROAD, NARROW, RELATED';
3352             }
3353 3         4 print $output_file_handle "\t\n";
3354 3         4 print $output_file_handle "\t\t\n";
3355 3         7 print $output_file_handle "\t\t\t", $synonym->def()->text(), "\n";
3356            
3357 3         7 __print_hasDbXref_for_owl($output_file_handle, $synonym->def()->dbxref_set(), $oboContentUrl, 3);
3358            
3359 3         5 print $output_file_handle "\t\t\n";
3360 3         7 print $output_file_handle "\t\n";
3361             }
3362             #
3363             # namespace: TODO implement namespace in relationship
3364             #
3365 29         68 foreach my $ns ($relationship_type->namespace()) {
3366 0         0 print $output_file_handle "\t", $ns, "\n";
3367             }
3368            
3369             #
3370             # alt_id: TODO implement alt_id in relationship
3371             #
3372 29         84 foreach my $alt_id ($relationship_type->alt_id()->get_set()) {
3373 0         0 print $output_file_handle "\t", $alt_id, "\n";
3374             }
3375            
3376             #
3377             # is_a:
3378             #
3379 29         70 my $rt = $self->get_relationship_type_by_id('is_a');
3380 29 50       50 if (defined $rt) {
3381 29     28   78 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($relationship_type, $rt)});
  28         90  
  29         45  
3382 29         73 foreach my $head (@sorted_heads) {
3383 28         56 print $output_file_handle "\tid()), "\"/>\n"; # head->name() not used
3384             }
3385             }
3386            
3387             #
3388             # Properties:
3389             #
3390 29 100       63 print $output_file_handle "\t\n" if ($relationship_type->is_transitive());
3391 29 100       48 print $output_file_handle "\t\n" if ($relationship_type->is_symmetric()); # No cases so far
3392 29 50       50 print $output_file_handle "\t\n" if ($relationship_type->is_metadata_tag());
3393 29 50       125 print $output_file_handle "\t\n" if ($relationship_type->is_class_level());
3394             #print $output_file_handle "\ttrue\n" if ($relationship_type->is_reflexive());
3395             #print $output_file_handle "\ttrue\n" if ($relationship_type->is_anti_symmetric()); # anti-symmetric <> not symmetric
3396            
3397             #
3398             # xref's
3399             #
3400 29         54 __print_hasDbXref_for_owl($output_file_handle, $relationship_type->xref_set(), $oboContentUrl, 1);
3401            
3402             ## There is no way to code these rel's in OBO
3403             ##print $output_file_handle "\t\n" if (${$relationship{$_}}{"TODO"});
3404             ##print $output_file_handle "\t\n" if (${$relationship{$_}}{"TODO"});
3405             ##print $output_file_handle "\t\n" if (${$relationship{$_}}{"TODO"});
3406 29         43 print $output_file_handle "\n\n";
3407            
3408             #
3409             # replaced_by
3410             #
3411 29         87 foreach my $replaced_by ($relationship_type->replaced_by()->get_set()) {
3412 0         0 print $output_file_handle "\t\n";
3413             }
3414            
3415             #
3416             # consider
3417             #
3418 29         58 foreach my $consider ($relationship_type->consider()->get_set()) {
3419 0         0 print $output_file_handle "\t\n";
3420             }
3421             }
3422             #
3423             # #
3424             # # Datatype annotation properties: todo: AnnotationProperty or not?
3425             # #
3426             #
3427             # # autoGeneratedBy
3428             # #print $output_file_handle "\n";
3429             # #print $output_file_handle "\t\n";
3430             # #print $output_file_handle "\t\n";
3431             # #print $output_file_handle "\t", "The program that generated this ontology.", "\n";
3432             # #print $output_file_handle "\n\n";
3433             #
3434             # # is_anti_symmetric
3435             # print $output_file_handle "\n";
3436             # print $output_file_handle "\t\n";
3437             # print $output_file_handle "\n\n";
3438             #
3439             # # is_reflexive
3440             # print $output_file_handle "\n";
3441             # print $output_file_handle "\t\n";
3442             # print $output_file_handle "\n\n";
3443            
3444             #
3445             # EOF:
3446             #
3447 2         8 print $output_file_handle "\n\n";
3448 2         16 print $output_file_handle "";
3449             }
3450              
3451             =head2 export2xml
3452              
3453             See - OBO::Core::Ontology::export()
3454            
3455             =cut
3456              
3457             sub export2xml {
3458            
3459 2     2 1 4 my ($self, $output_file_handle, $error_file_handle) = @_;
3460            
3461             # terms
3462 2         2 my @all_terms = @{$self->get_terms_sorted_by_id()};
  2         8  
3463            
3464             # terms idspace
3465 2         19 my $NS = lc ($self->get_terms_idspace());
3466            
3467             # preambule: OBO header tags
3468 2         27 print $output_file_handle "\n\n";
3469 2         8 print $output_file_handle "<".$NS.">\n";
3470            
3471 2         4 print $output_file_handle "\t
\n";
3472 2         4 print $output_file_handle "\t\t1.4\n";
3473              
3474 2         8 my $data_version = $self->data_version();
3475 2 50       6 print $output_file_handle "\t\t", $data_version, "\n" if ($data_version);
3476            
3477 2         6 my $ontology_id_space = $self->id();
3478 2 50       8 print $output_file_handle '\t\t', $ontology_id_space, "\n" if ($ontology_id_space);
3479            
3480 2 50       9 chomp(my $date = (defined $self->date())?$self->date():__date()); #`date '+%d:%m:%Y %H:%M'`);
3481 2         6 print $output_file_handle "\t\t", $date, "\n";
3482            
3483 2         6 my $saved_by = $self->saved_by();
3484 2 100       9 print $output_file_handle "\t\t", $saved_by, "\n" if ($saved_by);
3485              
3486 2         6 print $output_file_handle "\t\tONTO-PERL ", $VERSION, "\n";
3487            
3488             # import
3489 2         12 foreach my $import ($self->imports()->get_set()) {
3490 0         0 print $output_file_handle "\t\t", $import, "\n";
3491             }
3492            
3493             # subsetdef
3494 2         9 foreach my $subsetdef (sort {lc($a->name()) cmp lc($b->name())} $self->subset_def_map()->values()) {
  0         0  
3495 0         0 print $output_file_handle "\t\t\n";
3496 0         0 print $output_file_handle "\t\t\t", $subsetdef->name(), "\n";
3497 0         0 print $output_file_handle "\t\t\t", $subsetdef->description(), "\n";
3498 0         0 print $output_file_handle "\t\t\n";
3499             }
3500            
3501             # synonyntypedef
3502 2         7 foreach my $st ($self->synonym_type_def_set()->get_set()) {
3503 1         3 print $output_file_handle "\t\t\n";
3504 1         6 print $output_file_handle "\t\t\t", $st->name(), "\n";
3505 1         5 print $output_file_handle "\t\t\t", $st->scope(), "\n";
3506 1         3 print $output_file_handle "\t\t\t", $st->description(), "\n";
3507 1         3 print $output_file_handle "\t\t\n";
3508             }
3509              
3510             # idspace's
3511 2         8 foreach my $idspace ($self->idspaces()->get_set()) {
3512 0         0 print $output_file_handle "\t\t", $idspace->as_string(), "\n";
3513             }
3514            
3515             # default_relationship_id_prefix
3516 2         7 my $dris = $self->default_relationship_id_prefix();
3517 2 50       9 print $output_file_handle "\t\t", $dris, "\n" if (defined $dris);
3518            
3519             # default_namespace
3520 2         6 my $dns = $self->default_namespace();
3521 2 50       7 print $output_file_handle "\t\t", $dns, "\n" if (defined $dns);
3522            
3523             # remark's
3524 2         8 foreach my $remark ($self->remarks()->get_set()) {
3525 2         6 print $output_file_handle "\t\t", $remark, "\n";
3526             }
3527            
3528             # treat-xrefs-as-equivalent
3529 2         7 foreach my $id_space_xref_eq (sort {lc($a) cmp lc($b)} $self->treat_xrefs_as_equivalent()->get_set()) {
  0         0  
3530 0         0 print $output_file_handle '\t\t', $id_space_xref_eq, "\n";
3531             }
3532            
3533             # treat_xrefs_as_is_a
3534 2         6 foreach my $id_space_xref_eq (sort {lc($a) cmp lc($b)} $self->treat_xrefs_as_is_a()->get_set()) {
  0         0  
3535 0         0 print $output_file_handle '\t\t', $id_space_xref_eq, "\n";
3536             }
3537            
3538 2         4 print $output_file_handle "\t\n\n";
3539            
3540             #######################################################################
3541             #
3542             # terms
3543             #
3544             #######################################################################
3545 2         4 foreach my $term (@all_terms) {
3546             #
3547             # [Term]
3548             #
3549 651         799 print $output_file_handle "\t\n";
3550            
3551             #
3552             # id
3553             #
3554 651         1523 print $output_file_handle "\t\t", $term->id(), "\n";
3555            
3556             #
3557             # is_anonymous
3558             #
3559 651 50       1131 print $output_file_handle "\t\ttrue\n" if ($term->is_anonymous());
3560            
3561             #
3562             # name
3563             #
3564 651 50       1027 print $output_file_handle "\t\t", &__char_hex_http($term->name()), "\n" if (defined $term->name());
3565            
3566             #
3567             # namespace
3568             #
3569 651         1552 foreach my $ns ($term->namespace()) {
3570 0         0 print $output_file_handle "\t\t", $ns, "\n";
3571             }
3572            
3573             #
3574             # alt_id
3575             #
3576 651         1316 foreach my $alt_id ($term->alt_id()->get_set()) {
3577 0         0 print $output_file_handle "\t\t", $alt_id, "\n";
3578             }
3579              
3580             #
3581             # builtin
3582             #
3583 651 50       1240 print $output_file_handle "\t\ttrue\n" if ($term->builtin() == 1);
3584            
3585             #
3586             # property_value
3587             #
3588 651         1261 my @property_values = sort {$a->id() cmp $b->id()} $term->property_value()->get_set();
  0         0  
3589 651         941 foreach my $value (@property_values) {
3590 0 0       0 if (defined $value->head()->instance_of()) {
3591 0         0 print $output_file_handle "\t\t\n";
3592 0         0 print $output_file_handle "\t\t\t", $value->type(),"\n";
3593 0         0 print $output_file_handle "\t\t\thead()->instance_of()->id(),"\">", $value->head()->id(),"\n";
3594 0         0 print $output_file_handle "\t\t";
3595             } else {
3596 0         0 print $output_file_handle "\t\t\n";
3597 0         0 print $output_file_handle "\t\t\t", $value->type(),"\n";
3598 0         0 print $output_file_handle "\t\t\t", $value->head()->id(),"\n";
3599 0         0 print $output_file_handle "\t\t";
3600             }
3601             # TODO Finalise this implementation
3602 0         0 print $output_file_handle "\t\t\n";
3603             }
3604              
3605             #
3606             # def
3607             #
3608 651         1151 my $term_def = $term->def();
3609 651 100       1759 if (defined $term_def->text()) {
3610 489         737 print $output_file_handle "\t\t\n";
3611 489         827 print $output_file_handle "\t\t\t", &__char_hex_http($term_def->text()), "\n";
3612 489         999 for my $ref ($term_def->dbxref_set()->get_set()) {
3613 392         681 print $output_file_handle "\t\t\tname(), "\">\n";
3614 392         871 print $output_file_handle "\t\t\t\t", $ref->acc(),"\n";
3615 392         764 print $output_file_handle "\t\t\t\t", $ref->db(),"\n";
3616 392         755 print $output_file_handle "\t\t\t\n";
3617             }
3618 489         615 print $output_file_handle "\t\t\n";
3619             }
3620            
3621             #
3622             # comment
3623             #
3624 651         1293 my $comment = $term->comment();
3625 651 100       1202 print $output_file_handle "\t\t", &__char_hex_http($comment), "\n" if (defined $comment);
3626              
3627             #
3628             # subset
3629             #
3630 651         1149 foreach my $sset_name (sort {$a cmp $b} $term->subset()) {
  0         0  
3631 0 0       0 if ($self->subset_def_map()->contains_key($sset_name)) {
3632 0         0 print $output_file_handle "\t\t", $sset_name, "\n";
3633             } else {
3634 0         0 print $error_file_handle "\nThe term ", $term->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n";
3635             }
3636             }
3637              
3638             #
3639             # synonym:
3640             #
3641 651         1391 foreach my $synonym ($term->synonym_set()) {
3642 814         780 print $output_file_handle "\t\t\n";
3643 814         1562 print $output_file_handle "\t\t\t", &__char_hex_http($synonym->def()->text()), "\n";
3644 814         1513 print $output_file_handle "\t\t\t", $synonym->scope(),"\n";
3645 814         1330 for my $ref ($synonym->def()->dbxref_set()->get_set()) {
3646 10         14 print $output_file_handle "\t\t\t\n";
3647 10         18 print $output_file_handle "\t\t\t\t", $ref->acc(),"\n";
3648 10         21 print $output_file_handle "\t\t\t\t", $ref->db(),"\n";
3649 10         17 print $output_file_handle "\t\t\t\n";
3650             }
3651 814         1306 print $output_file_handle "\t\t\n";
3652             }
3653              
3654             #
3655             # xref
3656             #
3657 651     522   3076 my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $term->xref_set_as_string());
  522         1341  
  522         1062  
3658 651         1759 foreach my $xref (@sorted_xrefs) {
3659 522         1026 print $output_file_handle "\t\t", $xref->as_string(), "\n";
3660             }
3661            
3662             #
3663             # is_a
3664             #
3665 651         1251 my $rt = $self->get_relationship_type_by_id('is_a');
3666 651 50       987 if (defined $rt) {
3667 651         637 my %saw_is_a; # avoid duplicated arrows (RelationshipSet?)
3668 651     564   1502 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  564         1715  
  651         1063  
3669 651         2636 foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) {
3670 564         1035 my $head_name = $head->name();
3671 564 50       1036 my $head_name_to_print = (defined $head_name)?$head_name:"no_name";
3672 564         934 print $output_file_handle "\t\tid()."\">".$head_name_to_print."\n";
3673             }
3674             }
3675            
3676             #
3677             # intersection_of (at least 2 entries)
3678             #
3679 651         1277 foreach my $tr ($term->intersection_of()) {
3680             # TODO Improve this export
3681 0         0 my $tr_head = $tr->head();
3682 0         0 my $tr_type = $tr->type();
3683 0         0 my $tr_head_id = $tr_head->id();
3684 0         0 $tr_head_id =~ tr/:/_/;
3685 0         0 my $intersection_of_txt = "";
3686 0 0       0 $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil');
3687 0         0 $intersection_of_txt .= $tr_head_id;
3688 0         0 print $output_file_handle "\t\t", $intersection_of_txt, "\n";
3689             }
3690              
3691             #
3692             # union_of (at least 2 entries)
3693             #
3694 651         1370 foreach my $union_of_term_id ($term->union_of()) {
3695 0         0 $union_of_term_id =~ tr/:/_/;
3696 0         0 print $output_file_handle "\t\t", $union_of_term_id, "\n";
3697             }
3698            
3699             #
3700             # disjoint_from:
3701             #
3702 651         1355 foreach my $disjoint_term_id ($term->disjoint_from()) {
3703 4         13 print $output_file_handle "\t\t", $disjoint_term_id, "\n";
3704             }
3705            
3706             #
3707             # relationship
3708             #
3709 651         600 foreach $rt ( @{$self->get_relationship_types_sorted_by_id()} ) {
  651         1012  
3710 19110 100       30631 if ($rt->name() ne 'is_a') { # is_a is printed above
3711 18459         12298 my %saw_rel; # avoid duplicated arrows (RelationshipSet?)
3712 18459     372   31178 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  372         1147  
  18459         23729  
3713 18459         45409 foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) {
3714 372         644 print $output_file_handle "\t\t\n";
3715 372         716 print $output_file_handle "\t\t\t", $rt->name(), "\n";
3716 372         779 print $output_file_handle "\t\t\tid(), "\">", $head->name(),"\n";
3717 372         972 print $output_file_handle "\t\t\n";
3718             }
3719             }
3720             }
3721              
3722             #
3723             # created_by
3724             #
3725 651 100       6373 print $output_file_handle "\t\t", $term->created_by(), "\n" if (defined $term->created_by());
3726              
3727             #
3728             # creation_date
3729             #
3730 651 100       1100 print $output_file_handle "\t\t", $term->creation_date(), "\n" if (defined $term->creation_date());
3731            
3732             #
3733             # modified_by
3734             #
3735 651 50       1202 print $output_file_handle "\t\t", $term->modified_by(), "\n" if (defined $term->modified_by());
3736              
3737             #
3738             # modification_date
3739             #
3740 651 50       1128 print $output_file_handle "\t\t", $term->modification_date(), "\n" if (defined $term->modification_date());
3741            
3742             #
3743             # is_obsolete
3744             #
3745 651 50       1039 print $output_file_handle "\t\ttrue\n" if ($term->is_obsolete());
3746              
3747             #
3748             # replaced_by
3749             #
3750 651         1215 foreach my $replaced_by ($term->replaced_by()->get_set()) {
3751 0         0 print $output_file_handle "\t\t", $replaced_by, "\n";
3752             }
3753            
3754             #
3755             # consider
3756             #
3757 651         1394 foreach my $consider ($term->consider()->get_set()) {
3758 0         0 print $output_file_handle "\t\t", $consider, "\n";
3759             }
3760              
3761             #
3762             # end
3763             #
3764 651         2189 print $output_file_handle "\t\n\n";
3765             }
3766            
3767             #######################################################################
3768             #
3769             # instances
3770             #
3771             #######################################################################
3772 2         4 my @all_instances = @{$self->get_instances_sorted_by_id()};
  2         6  
3773 2         5 foreach my $instance (@all_instances) {
3774             # TODO export instances
3775             }
3776            
3777             #######################################################################
3778             #
3779             # relationship types
3780             #
3781             #######################################################################
3782 2         4 foreach my $relationship_type ( @{$self->get_relationship_types_sorted_by_id()} ) {
  2         5  
3783 32         40 print $output_file_handle "\t\n";
3784            
3785             #
3786             # id
3787             #
3788 32         62 print $output_file_handle "\t\t", $relationship_type->id(), "\n";
3789            
3790             #
3791             # is_anonymous
3792             #
3793 32 50       79 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_anonymous());
3794            
3795             #
3796             # name
3797             #
3798 32         53 my $relationship_type_name = $relationship_type->name();
3799 32 50       56 if (defined $relationship_type_name) {
3800 32         50 print $output_file_handle "\t\t", &__char_hex_http($relationship_type_name), "\n";
3801             }
3802            
3803             #
3804             # namespace
3805             #
3806 32         71 foreach my $nasp ($relationship_type->namespace()) {
3807 0         0 print $output_file_handle "\t\t", $nasp, "\n";
3808             }
3809            
3810             #
3811             # alt_id
3812             #
3813 32         61 foreach my $alt_id ($relationship_type->alt_id()->get_set()) {
3814 0         0 print $output_file_handle "\t\t", $alt_id, "\n";
3815             }
3816            
3817             #
3818             # builtin
3819             #
3820 32 100       63 print $output_file_handle "\t\ttrue\n" if ($relationship_type->builtin() == 1);
3821            
3822             #
3823             # def
3824             #
3825 32         61 my $relationship_type_def = $relationship_type->def();
3826 32 100       80 if (defined $relationship_type_def->text()) {
3827 21         38 print $output_file_handle "\t\ttext()), "\">\n";
3828 21         49 for my $ref ($relationship_type_def->dbxref_set()->get_set()) {
3829 20         36 print $output_file_handle "\t\t\tname(), "\">\n";
3830 20         44 print $output_file_handle "\t\t\t\t", $ref->acc(),"\n";
3831 20         41 print $output_file_handle "\t\t\t\t", $ref->db(),"\n";
3832 20         32 print $output_file_handle "\t\t\t\n";
3833             }
3834 21         28 print $output_file_handle "\t\t\n";
3835             }
3836            
3837             #
3838             # comment
3839             #
3840 32 100       85 print $output_file_handle "\t\t", &__char_hex_http($relationship_type->comment()), "\n" if (defined $relationship_type->comment());
3841            
3842             #
3843             # subset
3844             #
3845 32         72 foreach my $sset_name ($relationship_type->subset()) {
3846 0 0       0 if ($self->subset_def_map()->contains_key($sset_name)) {
3847 0         0 print $output_file_handle "\t\t",$sset_name,"\n";
3848             } else {
3849 0         0 print $error_file_handle "\nThe relationship type ", $relationship_type->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n";
3850             }
3851             }
3852            
3853             #
3854             # synonym
3855             #
3856 32         64 foreach my $rt_synonym ($relationship_type->synonym_set()) {
3857 5         9 print $output_file_handle "\t\t\n";
3858 5         14 print $output_file_handle "\t\t\t", &__char_hex_http($rt_synonym->def()->text()), "\n";
3859 5         13 print $output_file_handle "\t\t\t", $rt_synonym->scope(),"\n";
3860 5         11 for my $ref ($rt_synonym->def()->dbxref_set()->get_set()) {
3861 0         0 print $output_file_handle "\t\t\t\n";
3862 0         0 print $output_file_handle "\t\t\t\t", $ref->acc(),"\n";
3863 0         0 print $output_file_handle "\t\t\t\t", $ref->db(),"\n";
3864 0         0 print $output_file_handle "\t\t\t\n";
3865             }
3866 5         10 print $output_file_handle "\t\t\n";
3867             }
3868            
3869             #
3870             # xref
3871             #
3872 32     32   172 my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $relationship_type->xref_set_as_string());
  32         81  
  32         58  
3873 32         91 foreach my $xref (@sorted_xrefs) {
3874 32         63 print $output_file_handle "\t\t", $xref->as_string(), "\n";
3875             }
3876            
3877             #
3878             # domain
3879             #
3880 32         76 foreach my $domain ($relationship_type->domain()->get_set()) {
3881 0         0 print $output_file_handle "\t\t", $domain, "\n";
3882             }
3883            
3884             #
3885             # range
3886             #
3887 32         74 foreach my $range ($relationship_type->range()->get_set()) {
3888 0         0 print $output_file_handle "\t\t", $range, "\n";
3889             }
3890            
3891 32 100       67 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_anti_symmetric() == 1);
3892 32 50       67 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_cyclic() == 1);
3893 32 100       57 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_reflexive() == 1);
3894 32 100       48 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_symmetric() == 1);
3895 32 100       55 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_transitive() == 1);
3896            
3897             #
3898             # is_a: TODO missing function to retieve the rel types
3899             #
3900 32         62 my $rt = $self->get_relationship_type_by_id('is_a');
3901 32 50       48 if (defined $rt) {
3902 32         29 my @heads = @{$self->get_head_by_relationship_type($relationship_type, $rt)};
  32         41  
3903 32         39 foreach my $head (@heads) {
3904 28         53 print $output_file_handle "\t\t", $head->id(), "\n";
3905             }
3906             }
3907            
3908             #
3909             # intersection_of (at least 2 entries)
3910             #
3911 32         67 foreach my $tr ($relationship_type->intersection_of()) {
3912             # TODO Improve this export
3913 0         0 my $tr_head = $tr->head();
3914 0         0 my $tr_type = $tr->type();
3915 0         0 my $tr_head_id = $tr_head->id();
3916 0         0 $tr_head_id =~ tr/:/_/;
3917 0         0 my $intersection_of_txt = "";
3918 0 0       0 $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil');
3919 0         0 $intersection_of_txt .= $tr_head_id;
3920 0         0 print $output_file_handle "\t\t", $intersection_of_txt, "\n";
3921             }
3922            
3923             #
3924             # union_of (at least 2 entries)
3925             #
3926 32         72 foreach my $union_of_rt_id ($relationship_type->union_of()) {
3927 0         0 $union_of_rt_id =~ tr/:/_/;
3928 0         0 print $output_file_handle "\t\t", $union_of_rt_id, "\n";
3929             }
3930            
3931             #
3932             # disjoint_from
3933             #
3934 32         63 my $df = $relationship_type->disjoint_from();
3935 32 50       61 if (defined $df) {
3936 0         0 print $output_file_handle "\t\t", $df, "\n";
3937             }
3938            
3939             #
3940             # inverse_of
3941             #
3942 32         58 my $ir = $relationship_type->inverse_of();
3943 32 100       52 if (defined $ir) {
3944 2         6 print $output_file_handle "\t\t", $ir->id(), "\n";
3945             }
3946            
3947             #
3948             # transitive_over
3949             #
3950 32         55 foreach my $transitive_over ($relationship_type->transitive_over()->get_set()) {
3951 0         0 print $output_file_handle "\t\t", $transitive_over, "\n";
3952             }
3953            
3954             #
3955             # holds_over_chain
3956             #
3957 32         65 foreach my $holds_over_chain ($relationship_type->holds_over_chain()) {
3958 0         0 print $output_file_handle "\t\t\n";
3959 0         0 print $output_file_handle "\t\t\t", @{$holds_over_chain}[0], "\n";
  0         0  
3960 0         0 print $output_file_handle "\t\t\t", @{$holds_over_chain}[1], "\n";
  0         0  
3961 0         0 print $output_file_handle "\t\t\n";
3962             }
3963              
3964             #
3965             # is_functional
3966             #
3967 32 50       64 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_functional() == 1);
3968            
3969             #
3970             # is_inverse_functional
3971             #
3972 32 50       55 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_inverse_functional() == 1);
3973            
3974             #
3975             # created_by
3976             #
3977 32 100       56 print $output_file_handle "\t\t", $relationship_type->created_by(), "\n" if (defined $relationship_type->created_by());
3978              
3979             #
3980             # creation_date
3981             #
3982 32 100       49 print $output_file_handle "\t\t", $relationship_type->creation_date(), "\n" if (defined $relationship_type->creation_date());
3983            
3984             #
3985             # is_obsolete
3986             #
3987 32 50       56 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_obsolete());
3988            
3989             #
3990             # replaced_by
3991             #
3992 32         62 foreach my $replaced_by ($relationship_type->replaced_by()->get_set()) {
3993 0         0 print $output_file_handle "\t\t", $replaced_by, "\n";
3994             }
3995            
3996             #
3997             # consider
3998             #
3999 32         60 foreach my $consider ($relationship_type->consider()->get_set()) {
4000 0         0 print $output_file_handle "\t\t", $consider, "\n";
4001             }
4002            
4003             #
4004             # is_metadata_tag
4005             #
4006 32 50       63 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_metadata_tag() == 1);
4007            
4008             #
4009             # is_class_level
4010             #
4011 32 50       59 print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_class_level() == 1);
4012            
4013             #
4014             # end typedef
4015             #
4016 32         76 print $output_file_handle "\t\n\n";
4017             }
4018 2         76 print $output_file_handle "\n";
4019             }
4020              
4021             =head2 export2dot
4022              
4023             See - OBO::Core::Ontology::export()
4024            
4025             =cut
4026              
4027             sub export2dot {
4028            
4029 2     2 1 4 my ($self, $output_file_handle, $error_file_handle) = @_;
4030            
4031             #
4032             # begin DOT format
4033             #
4034 2         23 print $output_file_handle 'digraph Ontology {';
4035 2         5 print $output_file_handle "\n\tpage=\"11,17\";";
4036             #print $output_file_handle "\n\tratio=auto;";
4037            
4038             # terms
4039 2         4 my @all_terms = @{$self->get_terms_sorted_by_id()};
  2         6  
4040 2         30 print $output_file_handle "\n\tedge [label=\"is a\"];";
4041 2         5 foreach my $term (@all_terms) {
4042            
4043 647         1538 my $term_id = $term->id();
4044            
4045             #
4046             # is_a: term1 -> term2
4047             #
4048 647         1109 my $rt = $self->get_relationship_type_by_id('is_a');
4049 647 50       1061 if (defined $rt) {
4050 647         460 my %saw_is_a; # avoid duplicated arrows (RelationshipSet?)
4051 647     560   2203 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  560         1663  
  647         798  
4052 647         2473 foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) {
4053 560 50       1041 if (!defined $term->name()) {
    50          
4054 0         0 warn 'Warning: The term with id: ', $term_id, ' has no name!' ;
4055             } elsif (!defined $head->name()) {
4056 0         0 warn 'Warning: The term with id: ', $head->id(), ' has no name!' ;
4057             } else {
4058             # TODO Write down the name() instead of the id()
4059 560         915 print $output_file_handle "\n\t", obo_id2owl_id($term_id), ' -> ', obo_id2owl_id($head->id()), ';';
4060             }
4061             }
4062             }
4063             #
4064             # relationships: terms1 -> term2
4065             #
4066 647         708 foreach $rt ( @{$self->get_relationship_types_sorted_by_id()} ) {
  647         981  
4067 19091 100       31736 if ($rt->name() ne 'is_a') { # is_a is printed above
4068 18444         11871 my @heads = @{$self->get_head_by_relationship_type($term, $rt)};
  18444         20127  
4069 18444 100       26640 print $output_file_handle "\n\tedge [label=\"", $rt->name(), "\"];" if (@heads);
4070 18444         13138 my %saw_rel; # avoid duplicated arrows (RelationshipSet?)
4071 18444     370   36912 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @heads);
  370         1048  
4072 18444         47088 foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) {
4073 370 50       649 if (!defined $term->name()) {
    50          
4074 0         0 warn 'Warning: The term with id: ', $term_id, ' has no name!' ;
4075             } elsif (!defined $head->name()) {
4076 0         0 warn 'Warning: The term with id: ', $head->id(), ' has no name!' ;
4077             } else {
4078 370         746 print $output_file_handle "\n\t", obo_id2owl_id($term_id), ' -> ', obo_id2owl_id($head->id()), ';';
4079             }
4080             }
4081             }
4082             }
4083             }
4084            
4085             #
4086             # end DOT format
4087             #
4088 2         96 print $output_file_handle "\n}";
4089             }
4090              
4091             =head2 export2gml
4092              
4093             See - OBO::Core::Ontology::export()
4094            
4095             =cut
4096              
4097             sub export2gml {
4098            
4099 0     0 1 0 my ($self, $output_file_handle, $error_file_handle) = @_;
4100            
4101             #
4102             # begin GML format
4103             #
4104 0         0 print $output_file_handle "Creator \"ONTO-PERL, $VERSION\"\n";
4105 0         0 print $output_file_handle "Version 1.0\n";
4106 0         0 print $output_file_handle "graph [\n";
4107             #print $output_file_handle "\tVendor \"ONTO-PERL\"\n";
4108             #print $output_file_handle "\tdirected 1\n";
4109             #print $output_file_handle "\tcomment 1"
4110             #print $output_file_handle "\tlabel 1"
4111            
4112 0         0 my %id = ('C'=>1, 'P'=>2, 'F'=>3, 'R'=>4, 'T'=>5, 'I'=>6, 'B'=>7, 'U'=>8, 'G'=>9, 'X'=>4);
4113 0         0 my %color_id = ('C'=>'fff5f5', 'P'=>'b7ffd4', 'F'=>'d7ffe7', 'R'=>'ceffe1', 'T'=>'ffeaea', 'I'=>'f4fff8', 'B'=>'f0fff6', 'G'=>'f0fee6', 'U'=>'e0ffec', 'X'=>'ffcccc', 'Y'=>'fecccc');
4114 0         0 my %gml_id;
4115             # terms
4116 0         0 my @all_terms = @{$self->get_terms_sorted_by_id()};
  0         0  
4117 0         0 foreach my $term (@all_terms) {
4118            
4119 0         0 my $term_id = $term->id();
4120             #
4121             # Class name
4122             #
4123 0         0 print $output_file_handle "\tnode [\n";
4124 0         0 my $term_sns = $term->subnamespace();
4125 0 0       0 $term_sns = 'X' if !$term_sns;
4126 0         0 my $id = $id{$term_sns};
4127 0 0       0 $gml_id{$term_id} = 100000000 * (defined($id)?$id:1) + $term->code();
4128             #$id{$term->id()} = $gml_id;
4129 0         0 print $output_file_handle "\t\troot_index -", $gml_id{$term_id}, "\n";
4130 0         0 print $output_file_handle "\t\tid -", $gml_id{$term_id}, "\n";
4131 0         0 print $output_file_handle "\t\tgraphics [\n";
4132             #print $output_file_handle "\t\t\tx 1656.0\n";
4133             #print $output_file_handle "\t\t\ty 255.0\n";
4134 0         0 print $output_file_handle "\t\t\tw 40.0\n";
4135 0         0 print $output_file_handle "\t\t\th 40.0\n";
4136 0 0       0 print $output_file_handle "\t\t\tfill \"#".$color_id{$term_sns}."\"\n" if $color_id{$term_sns};
4137 0         0 print $output_file_handle "\t\t\toutline \"#000000\"\n";
4138 0         0 print $output_file_handle "\t\t\toutline_width 1.0\n";
4139 0         0 print $output_file_handle "\t\t]\n";
4140 0         0 print $output_file_handle "\t\tlabel \"", $term_id, "\"\n";
4141 0         0 print $output_file_handle "\t\tname \"", $term->name(), "\"\n";
4142 0 0       0 print $output_file_handle "\t\tcomment \"", $term->def()->text(), "\"\n" if (defined $term->def()->text());
4143 0         0 print $output_file_handle "\t]\n";
4144            
4145             #
4146             # relationships: terms1 -> term2
4147             #
4148 0         0 foreach my $rt ( @{$self->get_relationship_types_sorted_by_id()} ) {
  0         0  
4149 0         0 my %saw_rel; # avoid duplicated arrows (RelationshipSet?)
4150 0     0   0 my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)});
  0         0  
  0         0  
4151 0         0 foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) {
4152 0 0       0 if (!defined $term->name()) {
    0          
4153 0         0 croak 'The term with id: ', $term_id, ' has no name!' ;
4154             } elsif (!defined $head->name()) {
4155 0         0 croak 'The term with id: ', $head->id(), ' has no name!' ;
4156             } else {
4157 0         0 print $output_file_handle "\tedge [\n";
4158 0         0 print $output_file_handle "\t\troot_index -", $gml_id{$term_id}, "\n";
4159 0         0 print $output_file_handle "\t\tsource -", $gml_id{$term_id}, "\n";
4160 0 0       0 $gml_id{$head->id()} = 100000000 * (defined($id{$head->subnamespace()})?$id{$head->subnamespace()}:1) + $head->code();
4161 0         0 print $output_file_handle "\t\ttarget -", $gml_id{$head->id()}, "\n";
4162 0         0 print $output_file_handle "\t\tlabel \"", $rt->name(),"\"\n";
4163 0         0 print $output_file_handle "\t]\n";
4164             }
4165             }
4166             }
4167             }
4168            
4169             #
4170             # end GML format
4171             #
4172 0         0 print $output_file_handle "\n]";
4173             }
4174              
4175             =head2 export
4176              
4177             Usage - $ontology->export($export_format, $output_file_handle, $error_file_handle)
4178             Returns - exports this ontology
4179             Args - the format: obo, xml, owl, dot, gml, xgmml, sbml
4180             - the output file handle (e.g. STDOUT), and
4181             - the error file handle (STDERR by default; if not writable, STDOUT is used)
4182             Function - exports this ontology
4183             Remark - warning and errors are printed to the STDERR (by default)
4184             Remark - you may use this method to check your OBO file syntax and/or to clean it up
4185             Remark - Standard arguments:
4186             - 1. Format, one of 'obo', 'rdf', 'xml', 'owl', 'dot', 'gml', 'xgmml', 'sbml'
4187             - 2. Otput filehandle \*OUT
4188             - 3. Error filehandle \*ERR ( default \*STDERR, but for RDF or OWL )
4189             - Extra arguments:
4190             - 'rdf':
4191             - 1. base URI (e.g. 'http://www.semantic-systems-biology.org/')
4192             - 2. name space (e.g. 'SSB')
4193             - 3. Flag, 1=construct closures, 0=no closures (default)
4194             - 4. Flag, 1=skip exporting Typedefs, 0=export Typedefs (default)
4195             - 'owl':
4196             - 1. URI for content
4197             - 2. URI for OboInOwl (optional)
4198             - 3. note: the OWL export is broken!
4199              
4200             =cut
4201              
4202             sub export {
4203            
4204 16     16 1 2093 my $self = shift;
4205 16         51 my $format = lc(shift);
4206            
4207 16         88 my $possible_formats = OBO::Util::Set->new();
4208 16         108 $possible_formats->add_all('obo', 'rdf', 'xml', 'owl', 'dot', 'gml', 'xgmml', 'sbml');
4209 16 50       90 if (!$possible_formats->contains($format)) {
4210 0         0 croak "The export format must be one of the following: 'obo', 'rdf', 'xml', 'owl', 'dot', 'gml', 'xgmml', 'sbml'";
4211             }
4212            
4213 16         32 my $stderr_fh = \*STDERR;
4214 16         26 my $output_file_handle = shift;
4215 16   66     66 my $error_file_handle = shift || $stderr_fh;
4216            
4217             # check the file_handle's
4218 16 50       243 if (!-w $output_file_handle) {
    50          
4219 0         0 croak "export: you must provide a valid output handle, e.g. export('$format', \\*STDOUT)";
4220             } elsif (!-e $error_file_handle) {
4221 0         0 croak "export: you must provide a valid error handle, e.g. export('$format', \\*STDOUT, \\*STDERR)";
4222             }
4223            
4224 16 50 33     122 if (($error_file_handle eq $stderr_fh) && (!-w $error_file_handle)) {
4225 0         0 $error_file_handle = $output_file_handle;
4226             # TODO A few CPAN test platforms (e.g. solaris) don't have this handle open for testing
4227             #warn "export: the STDERR is not writable!";
4228             }
4229              
4230 16 100       77 if ($format eq 'obo') {
    100          
    100          
    100          
    50          
    0          
    0          
    0          
4231            
4232 8         38 $self->export2obo($output_file_handle, $error_file_handle);
4233            
4234             } elsif ($format eq 'rdf') {
4235            
4236 2         4 my $base = shift;
4237 2         3 my $namespace = shift;
4238 2   50     9 my $rdf_tc = shift || 0; # Set this according to your needs: 1=reflexive relations for each term
4239 2   50     7 my $skip = shift || 0; # Set this according to your needs: 1=skip exporting the rel types, 0=do not skip (default)
4240            
4241 2         10 $self->export2rdf($output_file_handle, $error_file_handle, $base, $namespace, $rdf_tc, $skip);
4242            
4243             } elsif ($format eq 'xml') {
4244            
4245 2         8 $self->export2xml($output_file_handle, $error_file_handle);
4246            
4247             } elsif ($format eq 'owl') {
4248              
4249 2         4 my $oboContentUrl = shift; # e.g. 'http://www.cellcycleontology.org/ontology/owl/'; # "http://purl.org/obo/owl/";
4250 2         4 my $oboInOwlUrl = shift; # e.g. 'http://www.cellcycleontology.org/formats/oboInOwl#'; # "http://www.geneontology.org/formats/oboInOwl#";
4251              
4252 2         11 $self->export2owl($output_file_handle, $error_file_handle, $oboContentUrl, $oboInOwlUrl);
4253            
4254             } elsif ($format eq 'dot') {
4255            
4256 2         8 $self->export2dot($output_file_handle, $error_file_handle);
4257            
4258             } elsif ($format eq 'gml') {
4259            
4260 0         0 $self->export2gml($output_file_handle, $error_file_handle);
4261            
4262             } elsif ($format eq 'xgmml') {
4263 0         0 warn 'Not implemented yet';
4264             } elsif ($format eq 'sbml') {
4265 0         0 warn 'Not implemented yet';
4266             }
4267            
4268 16         110 return 0;
4269             }
4270              
4271             =head2 subontology_by_terms
4272              
4273             Usage - $ontology->subontology_by_terms($term_set)
4274             Returns - a subontology with the given terms from this ontology
4275             Args - the terms (OBO::Util::TermSet) that will be included in the subontology
4276             Function - creates a subontology based on the given terms from this ontology
4277             Remark - instances of terms (classes) are added to the resulting ontology
4278            
4279             =cut
4280              
4281             sub subontology_by_terms {
4282 1     1 1 5 my ($self, $term_set) = @_;
4283              
4284             # Future improvement: performance of this algorithm
4285 1         4 my $result = OBO::Core::Ontology->new();
4286 1         3 foreach my $term ($term_set->get_set()) {
4287             #
4288             # add term
4289             #
4290 3 50       8 if (!$result->has_term($term)) {
4291 3         6 $result->add_term($term); # add term
4292 3         8 foreach my $ins ($term->class_of()->get_set()) {
4293 3         10 $result->add_instance($ins); # add its instances
4294             }
4295             }
4296            
4297             #
4298             # add descendents
4299             #
4300 3         4 foreach my $descendent (@{$self->get_descendent_terms($term)}) {
  3         7  
4301 3 50       7 if (!$result->has_term($descendent)) {
4302 0         0 $result->add_term($descendent); # add descendent
4303 0         0 foreach my $ins ($descendent->class_of()->get_set()) {
4304 0         0 $result->add_instance($ins); # add its instances
4305             }
4306             }
4307             }
4308             #
4309             # rel's
4310             #
4311 3         4 foreach my $rel (@{$self->get_relationships_by_target_term($term)}){
  3         5  
4312 3         5 $result->add_relationship($rel);
4313 3         7 my $rel_type = $self->get_relationship_type_by_id($rel->type());
4314 3 50       6 $result->has_relationship_type($rel_type) || $result->add_relationship_type($rel_type);
4315             }
4316             }
4317 1         4 return $result;
4318             }
4319              
4320             =head2 get_subontology_from
4321              
4322             Usage - $ontology->get_subontology_from($new_root_term)
4323             Returns - a subontology from the given term of this ontology
4324             Args - the term (OBO::Core::Term) that is the root of the subontology, and optionally, a reference to relationship type ids
4325             Function - creates a subontology having as root the given term
4326            
4327             =cut
4328              
4329             sub get_subontology_from {
4330 3     3 1 36 my ($self,
4331             $root_term,
4332             $rel_type_ids #vlmir - ref {relationsship type id => relationship type name}; optional
4333             ) = @_;
4334 3         17 my $result = OBO::Core::Ontology->new();
4335 3 50       8 if ($root_term) {
4336 3 50       9 $self->has_term($root_term) || croak "The term '", $root_term,"' does not belong to this ontology";
4337              
4338 3         12 $result->data_version($self->data_version());
4339 3         8 $result->id($self->id());
4340 3         13 $result->imports($self->imports()->get_set());
4341 3         9 $result->idspaces($self->idspaces()->get_set());
4342 3         10 $result->subset_def_map($self->subset_def_map()); # add (by default) all the subset_def_map's
4343 3         9 $result->synonym_type_def_set($self->synonym_type_def_set()->get_set()); # add all synonym_type_def_set by default
4344 3         14 $result->default_relationship_id_prefix($self->default_relationship_id_prefix());
4345 3         8 $result->default_namespace($self->default_namespace());
4346 3         8 $result->remarks($self->remarks()->get_set());
4347 3         11 $result->treat_xrefs_as_equivalent($self->treat_xrefs_as_equivalent->get_set());
4348 3         8 $result->treat_xrefs_as_is_a($self->treat_xrefs_as_is_a->get_set());
4349            
4350 3 50       7 if ( $rel_type_ids ) { #vlmir
4351 0         0 foreach my $rel_type_id ( sort keys %{$rel_type_ids} ) {
  0         0  
4352 0         0 $result->add_relationship_type_as_string( $rel_type_id, $rel_type_ids->{$rel_type_id} );
4353             } #vlmir
4354             }
4355            
4356 3         5 my @queue = ($root_term);
4357 3         8 while (scalar(@queue) > 0) {
4358 40         45 my $unqueued = shift @queue;
4359 40         68 $result->add_term($unqueued);
4360 40         31 foreach my $rel (@{$self->get_relationships_by_target_term($unqueued)}){
  40         61  
4361 37 50       51 if ( $rel_type_ids ) { #vlmir
4362 0 0       0 $rel_type_ids->{$rel->type()} ? $result->add_relationship($rel) : next;
4363             } #vlmir
4364             else {
4365 37         48 $result->add_relationship($rel);
4366 37         62 my $rel_type = $self->get_relationship_type_by_id($rel->type()); #vlmir OBO::Core::RelationshipType
4367 37 50       49 $result->has_relationship_type($rel_type) || $result->add_relationship_type($rel_type);
4368             }
4369             }
4370 40         46 my @children = @{$self->get_child_terms($unqueued)};
  40         63  
4371 40         124 @queue = (@queue, @children);
4372             }
4373             }
4374 3         10 return $result;
4375             }
4376              
4377             =head2 get_terms_idspace
4378              
4379             Usage - $ontology->get_terms_idspace()
4380             Returns - the idspace (e.g. GO) of the terms held by this ontology (or 'NN' is there is no idspace)
4381             Args - none
4382             Function - look for the idspace of the terms held by this ontology
4383             Remark - it is assumed that most of the terms share the same idspace (e.g. GO)
4384            
4385             =cut
4386              
4387             sub get_terms_idspace {
4388 11     11 1 19 my ($self) = @_;
4389 11 100       27 if ($self->id()) {
4390 2         4 return $self->id();
4391             } else {
4392             # TODO Find an efficient way to get it...
4393             #my $is = (sort values(%{$self->{TERMS}}))[0]->idspace();
4394 9         14 my $NS = undef;
4395 9     1322   37 my @all_terms = __sort_by_id(sub {shift}, values(%{$self->{TERMS}}));
  1322         1865  
  9         203  
4396 9         244 foreach my $term (@all_terms) {
4397 8         38 $NS = $term->idspace();
4398 8 50       25 last if(defined $NS);
4399             }
4400 9 100       83 return ($NS)?$NS:'NN';
4401             }
4402             }
4403              
4404             =head2 get_instances_idspace
4405              
4406             Usage - $ontology->get_instances_idspace()
4407             Returns - the idspace (e.g. GO) of the instances held by this ontology (or 'NN' is there is no idspace)
4408             Args - none
4409             Function - look for the idspace of the instances held by this ontology
4410             Remark - it is assumed that most of the instances share the same idspace (e.g. GO)
4411            
4412             =cut
4413              
4414             sub get_instances_idspace {
4415 2     2 1 3 my ($self) = @_;
4416 2 50       4 if ($self->id()) {
4417 0         0 return $self->id();
4418             } else {
4419             # TODO Find an efficient way to get it...
4420             #my $is = (sort values(%{$self->{INSTANCES}}))[0]->idspace();
4421 2         3 my $NS = undef;
4422 2         2 my @all_instances = sort values(%{$self->{INSTANCES}});
  2         13  
4423 2         3 foreach my $instance (@all_instances) {
4424 2         6 $NS = $instance->idspace();
4425 2 50       6 last if(defined $NS);
4426             }
4427 2 50       5 return ($NS)?$NS:'NN';
4428             }
4429             }
4430              
4431             =head2 get_descendent_terms
4432              
4433             Usage - $ontology->get_descendent_terms($term) or $ontology->get_descendent_terms($term_id)
4434             Returns - a set with the descendent terms (OBO::Core::Term) of the given term
4435             Args - the term, as an object (OBO::Core::Term) or string (e.g. GO:0003677), for which all the descendents will be found
4436             Function - returns recursively all the child terms of the given term
4437            
4438             =cut
4439              
4440             sub get_descendent_terms {
4441 12     12 1 214 my ($self, $term) = @_;
4442 12         31 my $result = OBO::Util::TermSet->new();
4443 12 50       24 if ($term) {
4444 12 100       11 if (!eval { $term->isa('OBO::Core::Term') }) {
  12         55  
4445             # term is a string representing its (unique) ID (e.g. GO:0034544)
4446 4         5 $term = $self->get_term_by_id($term);
4447             }
4448 12         12 my @queue = @{$self->get_child_terms($term)};
  12         21  
4449 12         29 while (scalar(@queue) > 0) {
4450 26         21 my $unqueued = pop @queue;
4451 26         44 $result->add($unqueued);
4452 26         18 my @children = @{$self->get_child_terms($unqueued)};
  26         39  
4453 26         62 @queue = (@children, @queue);
4454             }
4455             }
4456 12         23 my @arr = $result->get_set();
4457 12         37 return \@arr;
4458             }
4459              
4460             =head2 get_ancestor_terms
4461              
4462             Usage - $ontology->get_ancestor_terms($term)
4463             Returns - a set with the ancestor terms (OBO::Core::Term) of the given term
4464             Args - the term (OBO::Core::Term) for which all the ancestors will be found
4465             Function - returns recursively all the parent terms of the given term
4466            
4467             =cut
4468              
4469             sub get_ancestor_terms {
4470 5     5 1 116 my ($self, $term) = @_;
4471 5         14 my $result = OBO::Util::TermSet->new();
4472 5 50       16 if ($term) {
4473 5         3 my @queue = @{$self->get_parent_terms($term)};
  5         12  
4474 5         13 while (scalar(@queue) > 0) {
4475 13         13 my $unqueued = pop @queue;
4476 13         24 $result->add($unqueued);
4477 13         11 my @parents = @{$self->get_parent_terms($unqueued)};
  13         19  
4478 13         34 @queue = (@parents, @queue);
4479             }
4480             }
4481 5         9 my @arr = $result->get_set();
4482 5         19 return \@arr;
4483             }
4484              
4485             =head2 get_descendent_terms_by_subnamespace
4486              
4487             Usage - $ontology->get_descendent_terms_by_subnamespace($term, subnamespace)
4488             Returns - a set with the descendent terms (OBO::Core::Term) of the given subnamespace
4489             Args - the term (OBO::Core::Term), the subnamespace (string, e.g. 'P', 'R', 'Ia' etc)
4490             Function - returns recursively the given term's children of the given subnamespace
4491            
4492             =cut
4493              
4494             sub get_descendent_terms_by_subnamespace {
4495 4     4 1 104 my $self = shift;
4496 4         9 my $result = OBO::Util::TermSet->new();
4497 4 50       9 if (@_) {
4498 4         4 my ($term, $subnamespace) = @_;
4499 4         4 my @queue = @{$self->get_child_terms($term)};
  4         7  
4500 4         10 while (scalar(@queue) > 0) {
4501 7         6 my $unqueued = shift @queue;
4502 7 100       14 $result->add($unqueued) if substr($unqueued->id(), 4, length($subnamespace)) eq $subnamespace;
4503 7         8 my @children = @{$self->get_child_terms($unqueued)};
  7         8  
4504 7         17 @queue = (@queue, @children);
4505             }
4506             }
4507 4         9 my @arr = $result->get_set();
4508 4         14 return \@arr;
4509             }
4510              
4511             =head2 get_ancestor_terms_by_subnamespace
4512              
4513             Usage - $ontology->get_ancestor_terms_by_subnamespace($term, subnamespace)
4514             Returns - a set with the ancestor terms (OBO::Core::Term) of the given subnamespace
4515             Args - the term (OBO::Core::Term), the subnamespace (string, e.g. 'P', 'R', 'Ia' etc)
4516             Function - returns recursively the given term's parents of the given subnamespace
4517            
4518             =cut
4519              
4520             sub get_ancestor_terms_by_subnamespace {
4521 4     4 1 129 my $self = shift;
4522 4         11 my $result = OBO::Util::TermSet->new();
4523 4 50       9 if (@_) {
4524 4         5 my ($term, $subnamespace) = @_;
4525 4         1 my @queue = @{$self->get_parent_terms($term)};
  4         9  
4526 4         12 while (scalar(@queue) > 0) {
4527 11         14 my $unqueued = shift @queue;
4528 11 100       22 $result->add($unqueued) if substr($unqueued->id(), 4, length($subnamespace)) eq $subnamespace;
4529 11         8 my @parents = @{$self->get_parent_terms($unqueued)};
  11         15  
4530 11         28 @queue = (@queue, @parents);
4531             }
4532             }
4533 4         7 my @arr = $result->get_set();
4534 4         13 return \@arr;
4535             }
4536              
4537             =head2 get_descendent_terms_by_relationship_type
4538              
4539             Usage - $ontology->get_descendent_terms_by_relationship_type($term, $rel_type)
4540             Returns - a set with the descendent terms (OBO::Core::Term) of the given term linked by the given relationship type
4541             Args - OBO::Core::Term object, OBO::Core::RelationshipType object
4542             Function - returns recursively all the child terms of the given term linked by the given relationship type
4543            
4544             =cut
4545              
4546             sub get_descendent_terms_by_relationship_type {
4547 4     4 1 140 my $self = shift;
4548 4         11 my $result = OBO::Util::TermSet->new();
4549 4 50       9 if (@_) {
4550 4         5 my ($term, $type) = @_;
4551 4         3 my @queue = @{$self->get_tail_by_relationship_type($term, $type)};
  4         10  
4552 4         10 while (scalar(@queue) > 0) {
4553 4         5 my $unqueued = shift @queue;
4554 4         11 $result->add($unqueued);
4555 4         7 my @children = @{$self->get_tail_by_relationship_type($unqueued, $type)};
  4         5  
4556 4         9 @queue = (@queue, @children);
4557             }
4558             }
4559 4         9 my @arr = $result->get_set();
4560 4         14 return \@arr;
4561             }
4562              
4563             =head2 get_ancestor_terms_by_relationship_type
4564              
4565             Usage - $ontology->get_ancestor_terms_by_relationship_type($term, $rel_type)
4566             Returns - a set with the ancestor terms (OBO::Core::Term) of the given term linked by the given relationship type
4567             Args - OBO::Core::Term object, OBO::Core::RelationshipType object
4568             Function - returns recursively the parent terms of the given term linked by the given relationship type
4569            
4570             =cut
4571              
4572             sub get_ancestor_terms_by_relationship_type {
4573 4     4 1 194 my $self = shift;
4574 4         12 my $result = OBO::Util::TermSet->new();
4575 4 50       9 if (@_) {
4576 4         5 my ($term, $type) = @_;
4577 4         4 my @queue = @{$self->get_head_by_relationship_type($term, $type)};
  4         8  
4578 4         7 while (scalar(@queue) > 0) {
4579 5         6 my $unqueued = shift @queue;
4580 5         12 $result->add($unqueued);
4581 5         4 my @parents = @{$self->get_head_by_relationship_type($unqueued, $type)};
  5         8  
4582 5         12 @queue = (@queue, @parents);
4583             }
4584             }
4585 4         8 my @arr = $result->get_set();
4586 4         15 return \@arr;
4587             }
4588              
4589             =head2 get_term_by_xref
4590              
4591             Usage - $ontology->get_term_by_xref($db, $acc)
4592             Returns - the term (OBO::Core::Term) associated with the given external database ID. 'undef' is returned if there is no term for the given arguments.
4593             Args - the name of the external database and the ID (strings)
4594             Function - returns the term associated with the given external database ID
4595            
4596             =cut
4597              
4598             sub get_term_by_xref {
4599 3     3 1 5 my ($self, $db, $acc) = @_;
4600 3         3 my $result;
4601 3 50 33     12 if ($db && $acc) {
4602 3         3 foreach my $term (@{$self->get_terms()}) { # return the exact occurrence
  3         5  
4603 6         5 $result = $term;
4604 6         13 foreach my $xref ($term->xref_set_as_string()) {
4605 6 100 66     11 return $result if (($xref->db() eq $db) && ($xref->acc() eq $acc));
4606             }
4607             }
4608             }
4609 0         0 return undef;
4610             }
4611              
4612             =head2 get_instance_by_xref
4613              
4614             Usage - $ontology->get_instance_by_xref($db, $acc)
4615             Returns - the instance (OBO::Core::Instance) associated with the given external database ID. 'undef' is returned if there is no instance for the given arguments.
4616             Args - the name of the external database and the ID (strings)
4617             Function - returns the instance associated with the given external database ID
4618            
4619             =cut
4620              
4621             sub get_instance_by_xref {
4622 3     3 1 6 my ($self, $db, $acc) = @_;
4623 3         3 my $result;
4624 3 50 33     12 if ($db && $acc) {
4625 3         2 foreach my $instance (@{$self->get_instances()}) { # return the exact occurrence
  3         5  
4626 6         4 $result = $instance;
4627 6         13 foreach my $xref ($instance->xref_set_as_string()) {
4628 6 100 66     10 return $result if (($xref->db() eq $db) && ($xref->acc() eq $acc));
4629             }
4630             }
4631             }
4632 0         0 return undef;
4633             }
4634              
4635             =head2 get_paths_term1_term2
4636              
4637             Usage - $ontology->get_paths_term1_term2($term1_id, $term2_id)
4638             Returns - an array of references to the paths between term1 and term2
4639             Args - the IDs of the terms for which a path (or paths) will be found
4640             Function - returns the path(s) linking term1 and term2, where term1 is more specific than term2
4641            
4642             =cut
4643             sub get_paths_term1_term2 () {
4644 626     626 1 766 my ($self, $v, $bstop) = @_;
4645            
4646 626     1797   1491 my @nei = __sort_by_id(sub {shift}, @{$self->get_parent_terms($self->get_term_by_id($v))});
  1797         3017  
  626         1070  
4647            
4648 626         1463 my $path = $v;
4649 626         649 my @bk = ($v);
4650 626         528 my $p_id = $v;
4651            
4652 626         536 my %hijos;
4653             my %drop;
4654 0         0 my %banned;
4655            
4656 0         0 my @ruta;
4657 0         0 my @result;
4658            
4659 626         707 my $target_source_rels = $self->{TARGET_SOURCE_RELATIONSHIPS};
4660            
4661 626         1058 while ($#nei > -1) {
4662 11297         8900 my @back;
4663 11297         9625 my $n = pop @nei; # neighbours
4664 11297         20197 my $n_id = $n->id();
4665              
4666 11297 100       18219 next if (!defined $p_id); # TODO investigate cases where $p_id might not be defined
4667 10611         17959 my $p = $self->get_term_by_id($p_id);
4668            
4669 10611     9500   20253 my @ps = __sort_by_id(sub {shift}, @{$self->get_parent_terms($n)});
  9500         17442  
  10611         14604  
4670 10611     28390   27107 my @hi = __sort_by_id(sub {shift}, @{$self->get_parent_terms($p)});
  28390         45418  
  10611         13476  
4671            
4672 10611         26562 $hijos{$p_id} = $#hi + 1;
4673 10611         11428 $hijos{$n_id} = $#ps + 1;
4674 10611         11242 push @bk, $n_id;
4675            
4676             # add the (candidate) relationship
4677 10611     10490   19741 push @ruta, __sort_by_id(sub {shift}, values(%{$target_source_rels->{$p}->{$n}}));
  10490         20010  
  10611         29753  
4678              
4679 10611 100       23906 if ($bstop eq $n_id) {
4680            
4681             #print STDERR "\n\nSTOP FOUND : ", $n_id if ($v == 103 && $bstop == 265); # DEBUG
4682             #print STDERR "\nPATH : ", $path if ($v == 103); # DEBUG
4683             #print STDERR "\nBK : ", map {$_.'->'} @bk if ($v == 103); # DEBUG
4684             #print STDERR "\nRUTA : ", map {$_->id()} @ruta if ($v == 103); # DEBUG
4685            
4686 883         1148 $path .= '->'.$n_id;
4687 883         1186 push @result, [@ruta];
4688             }
4689            
4690 10611 100       13578 if ($#ps == -1) { # leaf
4691 4516         4057 my $sou = $p_id;
4692 4516         3993 $p_id = pop @bk;
4693 4516         3461 pop @ruta;
4694            
4695             #push @back, $p_id; # hold the un-stacked ones
4696              
4697             # NOTE: The following 3 lines of code are misteriously not used anymore...
4698             # banned relationship
4699             #my $source = $self->get_term_by_id($sou);
4700             #my $target = $self->get_term_by_id($p_id);
4701             #my $rr = sort values(%{$self->{TARGET_SOURCE_RELATIONSHIPS}->{$source}->{$target}});
4702            
4703 4516         4730 $banned{$sou}++;
4704 4516         4082 my $hijos_sou = $hijos{$sou};
4705 4516         3278 my $banned_sou = $banned{$sou};
4706 4516 50 33     14822 if (defined $banned_sou && $banned_sou > $hijos_sou){ # banned rel's from source
4707 0         0 $banned{$sou} = $hijos_sou;
4708             }
4709            
4710 4516         4921 $drop{$bk[$#bk]}++; # if (defined $drop{$bk[$#bk]} && $drop{$bk[$#bk]} < $hijos{$p_id});
4711            
4712 4516         3595 my $w = $#bk;
4713 4516         3048 my $bk_ww;
4714 4516   66     27588 while ( $w > -1
      100        
4715             &&
4716             ( $bk_ww = $bk[$w], ($hijos{$bk_ww} == 1 )
4717             || (defined $drop{$bk_ww} && $hijos{$bk_ww} == $drop{$bk_ww})
4718             || (defined $banned{$bk_ww} && $banned{$bk_ww} == $hijos{$bk_ww})
4719             )
4720             ) {
4721 6673         5760 $p_id = pop @bk;
4722 6673         5487 push @back, $p_id; # hold the un-stacked ones
4723            
4724 6673         4358 pop @ruta;
4725 6673 100       10302 $banned{$p_id}++ if ($banned{$p_id} < $hijos{$p_id}); # more banned rel's
4726            
4727 6673         4598 $w--;
4728 6673 100       9216 if ($w > -1) {
4729 6095         4965 my $bk_w = $bk[$w];
4730              
4731 6095         5794 $banned{$bk_w}++;
4732 6095         4980 my $hijos_bk_w = $hijos{$bk_w};
4733 6095         4281 my $banned_bk_w = $banned{$bk_w};
4734 6095 50 33     54007 if (defined $banned_bk_w && $banned_bk_w > $hijos_bk_w) {
4735 0         0 $banned{$bk_w} = $hijos_bk_w;
4736             }
4737             }
4738            
4739             }
4740             } else {
4741 6095         6029 $p_id = $n_id;
4742             }
4743            
4744 10611         9921 push @nei, @ps; # add next level
4745            
4746 10611         10314 $p_id = $bk[$#bk];
4747 10611         12646 $path .= '->'.$n_id;
4748              
4749             #
4750             # clean banned using the back (unstacked)
4751             #
4752 10611         19759 map {$banned{$_} = 0} @back;
  6673         12636  
4753             } # while
4754            
4755 626         2683 return @result;
4756             }
4757              
4758             =head2 get_paths_term_terms
4759              
4760             Usage - $ontology->get_paths_term_terms($term, $set_of_terms)
4761             Returns - an array of references to the paths between a given term ID and a given set of terms IDs
4762             Args - the ID of the term (string) for which a path (or paths) will be found and a set of terms (OBO::Util::Set)
4763             Function - returns the path(s) linking the given term and the given set of terms
4764            
4765             =cut
4766             sub get_paths_term_terms () {
4767 98     98 1 104 my ($self, $v, $bstop) = @_;
4768            
4769 98         83 my @nei = @{$self->get_parent_terms($self->get_term_by_id($v))};
  98         139  
4770            
4771 98         127 my $path = $v;
4772 98         98 my @bk = ($v);
4773 98         88 my $p_id = $v;
4774            
4775 98         64 my %hijos;
4776             my %drop;
4777 0         0 my %banned;
4778            
4779 0         0 my @ruta;
4780 0         0 my @result;
4781            
4782 98         101 my $target_source_rels = $self->{TARGET_SOURCE_RELATIONSHIPS};
4783 98         175 while ($#nei > -1) {
4784 465         363 my @back;
4785              
4786 465         440 my $n = pop @nei; # neighbours
4787 465         827 my $n_id = $n->id();
4788              
4789 465 50       722 next if (!defined $p_id); # TODO investigate cases where $p_id might not be defined
4790 465         700 my $p = $self->get_term_by_id($p_id);
4791            
4792 465         408 my @ps = @{$self->get_parent_terms($n)};
  465         610  
4793 465         503 my @hi = @{$self->get_parent_terms($p)};
  465         579  
4794            
4795 465         802 $hijos{$p_id} = $#hi + 1;
4796 465         538 $hijos{$n_id} = $#ps + 1;
4797 465         469 push @bk, $n_id;
4798            
4799             # add the (candidate) relationship
4800 465         362 push @ruta, sort values(%{$target_source_rels->{$p}->{$n}});
  465         1198  
4801            
4802 465 100       953 if ($bstop->contains($n_id)) {
4803             #warn "\nSTOP FOUND : ", $n_id;
4804 401         461 $path .= '->'.$n_id;
4805             #warn 'PATH : ', $path;
4806             #warn 'BK : ', map {$_.'->'} @bk;
4807             #warn 'RUTA : ', map {$_->id()} @ruta;
4808 401         593 push @result, [@ruta];
4809             }
4810            
4811 465 100       667 if ($#ps == -1) { # leaf
4812 159         142 my $sou = $p_id;
4813 159         149 $p_id = pop @bk;
4814 159         116 pop @ruta;
4815            
4816             #push @back, $p_id; # hold the un-stacked ones
4817            
4818             # NOTE: The following 3 lines of code are misteriously not used...
4819             # banned relationship
4820             #my $source = $self->get_term_by_id($sou);
4821             #my $target = $self->get_term_by_id($p_id);
4822             #my $rr = sort values(%{$self->{TARGET_SOURCE_RELATIONSHIPS}->{$source}->{$target}});
4823            
4824 159         180 $banned{$sou}++;
4825 159         143 my $hijos_sou = $hijos{$sou};
4826 159         138 my $banned_sou = $banned{$sou};
4827 159 50 33     508 if (defined $banned_sou && $banned_sou > $hijos_sou){ # banned rel's from source
4828 0         0 $banned{$sou} = $hijos_sou;
4829             }
4830            
4831 159         207 $drop{$bk[$#bk]}++; # if (defined $drop{$bk[$#bk]} && $drop{$bk[$#bk]} < $hijos{$p_id});
4832            
4833 159         135 my $w = $#bk;
4834 159         123 my $bk_ww;
4835 159   66     849 while ( $w > -1
      100        
4836             &&
4837             ( $bk_ww = $bk[$w], ($hijos{$bk_ww} == 1 )
4838             || (defined $drop{$bk_ww} && $hijos{$bk_ww} == $drop{$bk_ww})
4839             || (defined $banned{$bk_ww} && $banned{$bk_ww} == $hijos{$bk_ww})
4840             )
4841             ) {
4842 376         317 $p_id = pop @bk;
4843 376         324 push @back, $p_id; # hold the un-stacked ones
4844            
4845 376         256 pop @ruta;
4846 376 50       599 $banned{$p_id}++ if ($banned{$p_id} < $hijos{$p_id}); # more banned rel's
4847            
4848 376         262 $w--;
4849 376 100       607 if ($w > -1) {
4850 306         267 my $bk_w = $bk[$w];
4851            
4852 306         283 $banned{$bk_w}++;
4853 306         248 my $hijos_bk_w = $hijos{$bk_w};
4854 306         231 my $banned_bk_w = $banned{$bk_w};
4855 306 50 33     2364 if (defined $banned_bk_w && $banned_bk_w > $hijos_bk_w) {
4856 0         0 $banned{$bk_w} = $hijos_bk_w;
4857             }
4858             }
4859            
4860             }
4861             } else {
4862 306         310 $p_id = $n_id;
4863             }
4864 465         409 push @nei, @ps; # add next level
4865 465         446 $p_id = $bk[$#bk];
4866 465         469 $path .= '->'.$n_id;
4867            
4868             #
4869             # clean banned using the back (unstacked)
4870             #
4871 465         859 map {$banned{$_} = 0} @back;
  376         626  
4872             } # while
4873            
4874 98         372 return @result;
4875             }
4876              
4877             =head2 get_paths_term_terms_same_rel
4878              
4879             Usage - $ontology->get_paths_term_terms_same_rel($term_id, $set_of_terms, $type_of_relationship)
4880             Returns - an array of references to the paths between a given term ID and a given set of terms IDs
4881             Args - the ID of the term (string) for which a path (or paths) will be found, a set of terms (OBO::Util::Set) and the ID of the relationship type
4882             Function - returns the path(s) linking the given term (term ID) and the given set of terms along the same relationship (e.g. is_a)
4883            
4884             =cut
4885             sub get_paths_term_terms_same_rel () {
4886 134     134 1 151 my ($self, $v, $bstop, $rel) = @_;
4887            
4888             # TODO Check the case where there are reflexive relationships (e.g. GO:0000011_is_a_GO:0000011)
4889            
4890 134         181 my $r_type = $self->get_relationship_type_by_id($rel);
4891 134         111 my @nei = @{$self->get_head_by_relationship_type($self->get_term_by_id($v), $r_type)};
  134         190  
4892            
4893 134         167 my $path = $v;
4894 134         134 my @bk = ($v);
4895 134         100 my $p_id = $v;
4896            
4897 134         109 my %hijos;
4898             my %drop;
4899 0         0 my %banned;
4900            
4901 0         0 my @ruta;
4902 0         0 my @result;
4903            
4904 134         120 my $target_source_rels = $self->{TARGET_SOURCE_RELATIONSHIPS};
4905 134         224 while ($#nei > -1) {
4906            
4907 365         293 my @back;
4908              
4909 365         322 my $n = pop @nei; # neighbours
4910 365         895 my $n_id = $n->id();
4911              
4912 365 100       606 next if (!defined $p_id); # TODO investigate cases where $p_id might not be defined
4913 361         515 my $p = $self->get_term_by_id($p_id);
4914              
4915 361         303 my @ps = @{$self->get_head_by_relationship_type($n, $r_type)};
  361         481  
4916 361         317 my @hi = @{$self->get_head_by_relationship_type($p, $r_type)};
  361         467  
4917              
4918 361         572 $hijos{$p_id} = $#hi + 1;
4919 361         400 $hijos{$n_id} = $#ps + 1;
4920            
4921 361         346 push @bk, $n_id;
4922            
4923             # add the (candidate) relationship
4924 361         302 push @ruta, sort values(%{$target_source_rels->{$p}->{$n}});
  361         958  
4925            
4926 361 100       781 if ($bstop->contains($n_id)) {
4927             #warn "\nSTOP FOUND : ", $n_id;
4928 358         396 $path .= '->'.$n_id;
4929             #warn 'PATH : ', $path;
4930             #warn 'BK : ', map {$_.'->'} @bk;
4931             #warn 'RUTA : ', map {$_->id().'->'} @ruta;
4932 358         541 push @result, [@ruta];
4933             }
4934            
4935 361 100       532 if ($#ps == -1) { # leaf
4936 267         258 my $sou = $p_id;
4937 267         224 $p_id = pop @bk;
4938 267         212 pop @ruta;
4939            
4940             #push @back, $p_id; # hold the un-stacked ones
4941            
4942             # NOTE: The following 3 lines of code are misteriously not used...
4943             # banned relationship
4944             #my $source = $self->get_term_by_id($sou);
4945             #my $target = $self->get_term_by_id($p_id);
4946             #my $rr = sort values(%{$self->{TARGET_SOURCE_RELATIONSHIPS}->{$source}->{$target}});
4947            
4948 267         274 $banned{$sou}++;
4949 267         242 my $hijos_sou = $hijos{$sou};
4950 267         209 my $banned_sou = $banned{$sou};
4951 267 50 33     865 if (defined $banned_sou && $banned_sou > $hijos_sou){ # banned rel's from source
4952 0         0 $banned{$sou} = $hijos_sou;
4953             }
4954            
4955 267         307 $drop{$bk[$#bk]}++; # if (defined $drop{$bk[$#bk]} && $drop{$bk[$#bk]} < $hijos{$p_id});
4956            
4957 267         251 my $w = $#bk;
4958 267         204 my $bk_ww;
4959 267   66     2089 while ( $w > -1
      100        
4960             &&
4961             ( $bk_ww = $bk[$w], ($hijos{$bk_ww} == 1 )
4962             || (defined $drop{$bk_ww} && $hijos{$bk_ww} == $drop{$bk_ww})
4963             || (defined $banned{$bk_ww} && $banned{$bk_ww} == $hijos{$bk_ww})
4964             )
4965             ) {
4966 162         158 $p_id = pop @bk;
4967 162         145 push @back, $p_id; # hold the un-stacked ones
4968              
4969 162         106 pop @ruta;
4970 162 100       263 $banned{$p_id}++ if ($banned{$p_id} < $hijos{$p_id}); # more banned rel's
4971              
4972 162         120 $w--;
4973 162 100       291 if ($w > -1) {
4974 94         77 my $bk_w = $bk[$w];
4975              
4976 94         90 $banned{$bk_w}++;
4977 94         75 my $hijos_bk_w = $hijos{$bk_w};
4978 94         137 my $banned_bk_w = $banned{$bk_w};
4979 94 50 33     846 if (defined $banned_bk_w && $banned_bk_w > $hijos_bk_w) {
4980 0         0 $banned{$bk_w} = $hijos_bk_w;
4981             }
4982             }
4983             }
4984             } else {
4985 94         93 $p_id = $n_id;
4986             }
4987 361         332 push @nei, @ps; # add next level
4988 361         416 $p_id = $bk[$#bk];
4989 361         370 $path .= '->'.$n_id;
4990            
4991             #
4992             # clean banned using the back (unstacked)
4993             #
4994 361         676 map {$banned{$_} = 0} @back;
  162         343  
4995             } # while
4996            
4997 134         437 return @result;
4998             }
4999              
5000             =head2 obo_id2owl_id
5001              
5002             Usage - $ontology->obo_id2owl_id($term)
5003             Returns - the ID for OWL representation.
5004             Args - the OBO-type ID.
5005             Function - Transform an OBO-type ID into an OWL-type one. E.g. APO:I1234567 -> APO_I1234567
5006            
5007             =cut
5008              
5009             sub obo_id2owl_id {
5010 3473     3473 1 5351 $_[0] =~ tr/:/_/;
5011 3473         73541 return $_[0];
5012             }
5013              
5014             =head2 owl_id2obo_id
5015              
5016             Usage - $ontology->owl_id2obo_id($term)
5017             Returns - the ID for OBO representation.
5018             Args - the OWL-type ID.
5019             Function - Transform an OWL-type ID into an OBO-type one. E.g. APO_I1234567 -> APO:I1234567
5020            
5021             =cut
5022              
5023             sub owl_id2obo_id {
5024 0     0 1 0 $_[0] =~ tr/_/:/;
5025 0         0 return $_[0];
5026             }
5027              
5028             sub __date {
5029 12 50   12   48 caller eq __PACKAGE__ or croak;
5030 12         497 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
5031 12         334 my $result = sprintf "%02d:%02d:%4d %02d:%02d", $mday,$mon+1,$year+1900,$hour,$min; # e.g. 11:05:2008 12:52
5032             }
5033              
5034             sub __dfs () {
5035 0 0   0   0 caller eq __PACKAGE__ or croak;
5036 0         0 my ($self, $onto, $v) = @_;
5037            
5038 0         0 my $blist = OBO::Util::Set->new();
5039 0         0 my $brels = OBO::Util::Set->new();
5040            
5041 0         0 my $explored_set = OBO::Util::Set->new();
5042 0         0 $explored_set->add($v);
5043 0         0 my @nei = @{$onto->get_parent_terms($onto->get_term_by_id($v))};
  0         0  
5044            
5045 0         0 my $path = $v;
5046 0         0 my @bk = ($v);
5047 0         0 my $i = 0;
5048 0         0 my $p_id = $v;
5049 0         0 while ($#nei > -1) {
5050 0         0 my $n = pop @nei; # neighbors
5051 0         0 my $n_id = $n->id();
5052 0 0 0     0 if ($blist->contains($n_id) ||
  0         0  
5053             $brels->contains(sort values(%{$onto->{TARGET_SOURCE_RELATIONSHIPS}->
5054             {$onto->get_term_by_id($p_id)}->
5055             {$onto->get_term_by_id($n_id)}}))) {
5056 0         0 next;
5057             }
5058 0         0 my @ps = @{$onto->get_parent_terms($n)};
  0         0  
5059            
5060 0 0 0     0 if (!$blist->contains($n_id) || !$explored_set->contains($n_id)) {
5061 0         0 $explored_set->add($n_id);
5062 0         0 push @nei, @ps; # add next level
5063 0         0 $path .= '->'.$n_id;
5064 0         0 push @bk, $n_id;
5065 0         0 $i++;
5066             }
5067 0 0       0 if (!@ps) { # if leaf
5068            
5069 0 0       0 last if (!@nei);
5070            
5071 0         0 for (my $j = 0; $j < $i; $j++) {
5072 0         0 my $e = shift @bk;
5073 0         0 $explored_set->remove($e);
5074             }
5075 0         0 @nei = @{$onto->get_parent_terms($onto->get_term_by_id($v))};
  0         0  
5076 0         0 $i = 0;
5077 0         0 $path = $v; # init
5078            
5079 0         0 my $l = pop @bk;
5080 0         0 my $source = $onto->get_term_by_id($p_id);
5081 0         0 my $target = $onto->get_term_by_id($n_id);
5082 0         0 my $rr = values(%{$onto->{TARGET_SOURCE_RELATIONSHIPS}->{$source}->{$target}});
  0         0  
5083 0         0 $brels->add($rr->id());
5084            
5085             # banned terms
5086 0         0 my @crels = @{$onto->get_relationships_by_target_term($target)};
  0         0  
5087 0         0 my $all_banned = 1; # assume yes...
5088 0         0 foreach my $crel (@crels) {
5089 0 0       0 if (!$brels->contains($crel->id())) {
5090 0         0 $all_banned = 0;
5091 0         0 last;
5092             }
5093             }
5094 0 0       0 if ($all_banned) {
5095 0         0 $blist->add($l);
5096             }
5097              
5098             # banned rels
5099 0         0 my @drels = @{$onto->get_relationships_by_source_term($source)};
  0         0  
5100 0         0 my $all_rels_banned = 1;
5101 0         0 foreach my $drel (@drels) {
5102 0 0       0 if (!$brels->contains($drel->id())) {
5103 0         0 $all_rels_banned = 0;
5104 0         0 last;
5105             }
5106             }
5107 0 0       0 if ($all_rels_banned) {
5108 0         0 $blist->add($p_id);
5109             }
5110            
5111 0         0 @bk = ($v);
5112            
5113 0         0 $p_id = $v;
5114 0         0 next;
5115             }
5116 0         0 $p_id = $n_id;
5117             }
5118             }
5119              
5120             sub __get_name_without_whitespaces() {
5121 13667 50   13667   20515 caller eq __PACKAGE__ or croak;
5122 13667         18472 $_[0] =~ s/\s+/_/g;
5123 13667         13699 return $_[0];
5124             }
5125              
5126             sub __idspace_as_string {
5127 0 0   0   0 caller eq __PACKAGE__ or croak;
5128 0         0 my ($self, $local_id, $uri, $description) = @_;
5129 0 0 0     0 if ($local_id && $uri) {
5130 0         0 my $new_idspace = OBO::Core::IDspace->new();
5131 0         0 $new_idspace->local_idspace($local_id);
5132 0         0 $new_idspace->uri($uri);
5133 0 0       0 $new_idspace->description($description) if (defined $description);
5134 0         0 $self->idspaces($new_idspace);
5135 0         0 return $new_idspace;
5136             }
5137 0         0 my @idspaces = $self->idspaces()->get_set();
5138 0         0 my @idspaces_as_string = ();
5139 0         0 foreach my $idspace (@idspaces) {
5140 0         0 my $idspace_as_string = $idspace->local_idspace();
5141 0         0 $idspace_as_string .= ' '.$idspace->uri();
5142 0         0 my $idspace_description_string = $idspace->description();
5143 0 0       0 $idspace_as_string .= ' "'.$idspace_description_string.'"' if (defined $idspace_description_string);
5144            
5145 0         0 push @idspaces_as_string, $idspace_as_string;
5146             }
5147 0 0       0 if (!@idspaces_as_string) {
5148 0         0 return ''; # empty string
5149             } else {
5150             return @idspaces_as_string
5151 0         0 }
5152             }
5153              
5154             sub __sort_by {
5155 2848 50   2848   5783 caller eq __PACKAGE__ or croak;
5156 2848         3197 my ($subRef1, $subRef2, @input) = @_;
5157 1780         4033 my @result = map { $_->[0] } # restore original values
  306         424  
5158 1780         2670 sort { $a->[1] cmp $b->[1] } # sort
5159 2848         4025 map { [$_, &$subRef1($_->$subRef2())] } # transform: value, sortkey
5160             @input;
5161             }
5162              
5163             sub __sort_by_id {
5164 129368 50   129368   222103 caller eq __PACKAGE__ or croak;
5165 129368         126956 my ($subRef, @input) = @_;
5166 160306         237531 my @result = map { $_->[0] } # restore original values
  435849         353636  
5167 160306         237137 sort { $a->[1] cmp $b->[1] } # sort
5168 129368         164014 map { [$_, &$subRef($_->id())] } # transform: value, sortkey
5169             @input;
5170             }
5171              
5172             sub __print_hasDbXref_for_owl {
5173 1996 50   1996   3501 caller eq __PACKAGE__ or croak;
5174 1996         2094 my ($output_file_handle, $set, $oboContentUrl, $tab_times) = @_;
5175 1996         2521 my $tab0 = "\t"x$tab_times;
5176 1996         1994 my $tab1 = "\t"x($tab_times + 1);
5177 1996         1636 my $tab2 = "\t"x($tab_times + 2);
5178 1996         3622 for my $ref ($set->get_set()) {
5179 977         1454 print $output_file_handle $tab0."\n";
5180 977         974 print $output_file_handle $tab1."\n";
5181 977         1740 my $db = $ref->db();
5182 977         1633 my $acc = $ref->acc();
5183              
5184             # Special case when db=http and acc=www.domain.com
5185             # URL:http%3A%2F%2Fwww2.merriam-webster.com%2Fcgi-bin%2Fmwmednlm%3Fbook%3DMedical%26va%3Dforebrain
5186             # http%3A%2F%2Fwww2.merriam-webster.com%2Fcgi-bin%2Fmwmednlm%3Fbook%3DMedical%26va%3Dforebrain
5187 977 100       1434 if ($db eq 'http') {
5188 7         18 my $http_location = &__char_hex_http($acc);
5189 7         22 print $output_file_handle $tab2."URL:http%3A%2F%2F", $http_location, "\n";
5190 7         21 print $output_file_handle $tab2."",$http_location,"\n";
5191             } else {
5192 970         1728 print $output_file_handle $tab2."", $db, ":", $acc, "\n";
5193 970         3469 print $output_file_handle $tab2."",$oboContentUrl,$db,'#',$db,'_',$acc,"\n";
5194             }
5195 977         1352 print $output_file_handle $tab1."\n";
5196 977         2149 print $output_file_handle $tab0."\n";
5197             }
5198             }
5199              
5200             =head2 __char_hex_http
5201              
5202             Usage - $ontology->__char_hex_http($seq)
5203             Returns - the sequence with the numeric HTML representation for the given special character
5204             Args - the sequence of characters
5205             Function - Transforms a character into its equivalent HTML number, e.g. : -> :
5206            
5207             =cut
5208              
5209             sub __char_hex_http {
5210 6775 50   6775   13228 caller eq __PACKAGE__ or croak;
5211            
5212 6775         12667 $_[0] =~ s/:/:/g; # colon
5213 6775         8430 $_[0] =~ s/;/;/g; # semicolon
5214 6775         6996 $_[0] =~ s/
5215 6775         6937 $_[0] =~ s/=/=/g; # equal sign
5216 6775         6786 $_[0] =~ s/>/>/g; # greater than sign
5217 6775         6873 $_[0] =~ s/\?/?/g; # question mark
5218 6775         8033 $_[0] =~ s/\////g; # slash
5219 6775         8273 $_[0] =~ s/&/&/g; # ampersand
5220 6775         6603 $_[0] =~ s/"/"/g; # double quotes
5221 6775         7170 $_[0] =~ s/±/±/g; # plus-or-minus sign
5222              
5223 6775         18918 return $_[0];
5224             }
5225              
5226             1;
5227              
5228             __END__