# $Id: Ontology.pm 2012-10-03 erick.antezana $ # # Module : Ontology.pm # Purpose : OBO ontologies handling. # License : Copyright (c) 2006-2012 by Erick Antezana. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # Contact : Erick Antezana # package OBO::Core::Ontology; use OBO::Core::IDspace; use OBO::Util::IDspaceSet; use OBO::Util::SubsetDefMap; use OBO::Util::SynonymTypeDefSet; use OBO::Util::TermSet; use OBO::Util::InstanceSet; use OBO::Util::RelationshipTypeSet; use Carp; use strict; use warnings; our $VERSION = '1.40'; sub new { my $class = shift; my $self = {}; $self->{ID} = undef; # not required, (1) $self->{NAME} = undef; # not required, (0..1) $self->{IMPORTS} = OBO::Util::Set->new(); # set (0..N) $self->{TREAT_XREFS_AS_EQUIVALENT} = OBO::Util::Set->new(); # set (0..N) $self->{IDSPACES_SET} = OBO::Util::IDspaceSet->new(); # string (0..N) $self->{DEFAULT_NAMESPACE} = undef; # string (0..1) $self->{DATA_VERSION} = undef; # string (0..1) $self->{DATE} = undef; # (1) The current date in dd:MM:yyyy HH:mm format $self->{SAVED_BY} = undef; # string (0..1) $self->{REMARKS} = OBO::Util::Set->new(); # set (0..N) $self->{SUBSETDEF_MAP} = OBO::Util::SubsetDefMap->new(); # map of SubsetDef's (0..N); A subset is a view over an ontology $self->{SYNONYM_TYPE_DEF_SET} = OBO::Util::SynonymTypeDefSet->new(); # set (0..N); A description of a user-defined synonym type $self->{TERMS} = {}; # map: term_id(string) vs. term(OBO::Core::Term) (0..N) $self->{INSTANCES} = {}; # map: instance_id(string) vs. instance(OBO::Core::Instance) (0..N) $self->{RELATIONSHIP_TYPES} = {}; # map: relationship_type_id(string) vs. relationship_type(OBO::Core::RelationshipType) (0..N) $self->{RELATIONSHIPS} = {}; # (0..N) $self->{TERMS_SET} = OBO::Util::TermSet->new(); # Terms (0..n) # TODO Test this more deeply #$self->{INSTANCES_SET} = OBO::Util::TermSet->new(); # Instances (0..n) # TODO enable the instances_set #$self->{RELATIONSHIP_SET} = OBO::Util::RelationshipSet->new(); # TODO Implement RELATIONSHIP_SET $self->{TARGET_RELATIONSHIPS} = {}; # (0..N) $self->{SOURCE_RELATIONSHIPS} = {}; # (0..N) $self->{TARGET_SOURCE_RELATIONSHIPS} = {}; # (0..N) bless ($self, $class); return $self; } =head2 id Usage - print $ontology->id() or $ontology->id($id) Returns - the ID space of this ontology (string) Args - the ID space of this ontology (string) Function - gets/sets the ID space of this ontology =cut sub id { my ($self, $id) = @_; if ($id) { $self->{ID} = $id } return $self->{ID}; } =head2 name Usage - print $ontology->name() or $ontology->name($name) Returns - the name (string) of the ontology Args - the name (string) of the ontology Function - gets/sets the name of the ontology =cut sub name { my ($self, $name) = @_; if ($name) { $self->{NAME} = $name } return $self->{NAME}; } =head2 imports Usage - $onto->imports() or $onto->imports($id1, $id2, $id3, ...) Returns - a set (OBO::Util::Set) with the imported id ontologies Args - the ontology id(s) (string) Function - gets/sets the id(s) of the ontologies that are imported by this one =cut sub imports { my $self = shift; if (scalar(@_) > 1) { $self->{IMPORTS}->add_all(@_); } elsif (scalar(@_) == 1) { $self->{IMPORTS}->add($_[0]); } return $self->{IMPORTS}; } =head2 treat_xrefs_as_equivalent Usage - $onto->treat_xrefs_as_equivalent() or $onto->treat_xrefs_as_equivalent($xref1, $xref2, $xref3, ...) Returns - a set (OBO::Util::Set) of ontology id spaces Args - an ontology ID space(s) (string) Function - gets/sets the id spaces(s) of the ontologies that their xrefs are treated as equivalent =cut sub treat_xrefs_as_equivalent { my $self = shift; if (scalar(@_) > 1) { $self->{TREAT_XREFS_AS_EQUIVALENT}->add_all(@_); } elsif (scalar(@_) == 1) { $self->{TREAT_XREFS_AS_EQUIVALENT}->add($_[0]); } return $self->{TREAT_XREFS_AS_EQUIVALENT}; } =head2 date Usage - print $ontology->date() Returns - the current date (in dd:MM:yyyy HH:mm format) of the ontology Args - the current date (in dd:MM:yyyy HH:mm format) of the ontology Function - gets/sets the date of the ontology Remark - for historic reasons, this is NOT a ISO 8601 date, as is the case for the creation-date field =cut sub date { my ($self, $d) = @_; if ($d) { $self->{DATE} = $d } return $self->{DATE}; } =head2 default_namespace Usage - print $ontology->default_namespace() or $ontology->default_namespace("cellcycle_ontology") Returns - the default namespace (string) of this ontology Args - the default namespace (string) of this ontology Function - gets/sets the default namespace of this ontology =cut sub default_namespace { my ($self, $dns) = @_; if ($dns) { $self->{DEFAULT_NAMESPACE} = $dns } return $self->{DEFAULT_NAMESPACE}; } =head2 idspaces Usage - $ontology->idspaces() or $ontology->idspaces($IDspace) Returns - the id spaces, as a set (OBO::Util::IDspaceSet) of OBO::Core::IDspace's, of this ontology Args - the id spaces, as a set (OBO::Util::IDspaceSet) of OBO::Core::IDspace's, of this ontology Function - gets/sets the idspaces of this ontology =cut sub idspaces { my $self = shift; if (scalar(@_) > 1) { $self->{IDSPACES_SET}->add_all(@_); } elsif (scalar(@_) == 1) { $self->{IDSPACES_SET}->add($_[0]); } return $self->{IDSPACES_SET}; } =head2 data_version Usage - print $ontology->data_version() Returns - the data version (string) of this ontology Args - the data version (string) of this ontology Function - gets/sets the data version of this ontology =cut sub data_version { my ($self, $dv) = @_; if ($dv) { $self->{DATA_VERSION} = $dv } return $self->{DATA_VERSION}; } =head2 saved_by Usage - print $ontology->saved_by() Returns - the username of the person (string) to last save this ontology Args - the username of the person (string) to last save this ontology Function - gets/sets the username of the person to last save this ontology =cut sub saved_by { my ($self, $sb) = @_; if ($sb) { $self->{SAVED_BY} = $sb } return $self->{SAVED_BY}; } =head2 remarks Usage - print $ontology->remarks() Returns - the remarks (OBO::Util::Set) of this ontology Args - the remarks (OBO::Util::Set) of this ontology Function - gets/sets the remarks of this ontology =cut sub remarks { my $self = shift; if (scalar(@_) > 1) { $self->{REMARKS}->add_all(@_); } elsif (scalar(@_) == 1) { $self->{REMARKS}->add($_[0]); } return $self->{REMARKS}; } =head2 subset_def_map Usage - $onto->subset_def_map() or $onto->subset_def_map($subset_def_map) Returns - a map (OBO::Util::SubsetDefMap) with the subset definition(s) used in this ontology. A subset is a view over an ontology Args - a subset definitions map (OBO::Core::SubsetDefMap) Function - gets/sets the subset definition(s) of this ontology =cut sub subset_def_map { my $self = shift; $self->{SUBSETDEF_MAP}->put_all(@_); return $self->{SUBSETDEF_MAP}; } =head2 synonym_type_def_set Usage - $onto->synonym_type_def_set() or $onto->synonym_type_def_set($st1, $st2, $st3, ...) 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 Args - the synonym type definition(s) (OBO::Core::SynonymTypeDef) used in this ontology Function - gets/sets the synonym type definitions (s) of this ontology =cut sub synonym_type_def_set { my $self = shift; if (scalar(@_) > 1) { $self->{SYNONYM_TYPE_DEF_SET}->add_all(@_); } elsif (scalar(@_) == 1) { $self->{SYNONYM_TYPE_DEF_SET}->add($_[0]); } return $self->{SYNONYM_TYPE_DEF_SET}; } =head2 add_term Usage - $ontology->add_term($term) Returns - the just added term (OBO::Core::Term) Args - the term (OBO::Core::Term) to be added. The ID of the term to be added must have already been defined. Function - adds a term to this ontology Remark - adding a term to an ontology does not mean adding its instances =cut sub add_term { my ($self, $term) = @_; if ($term) { my $term_id = $term->id(); if ($term_id) { $self->{TERMS}->{$term_id} = $term; $self->{TERMS_SET}->add($term); return $term; } else { croak 'A term to be added to this ontology must have an ID.'; } } else { croak 'Missing term.'; } } =head2 add_instance Usage - $ontology->add_instance($instance) Returns - the just added instance (OBO::Core::Instance) Args - the instance (OBO::Core::Instance) to be added. The ID of the instance to be added must have already been defined. Function - adds a instance to this ontology =cut sub add_instance { my ($self, $instance) = @_; if ($instance) { my $instance_id = $instance->id(); if (defined $instance_id) { $self->{INSTANCES}->{$instance_id} = $instance; #$self->{INSTANCES_SET}->add($instance); return $instance; } else { croak 'A instance to be added to this ontology must have an ID.'; } } else { croak 'Missing instance.'; } } =head2 add_term_as_string Usage - $ontology->add_term_as_string($term_id, $term_name) Returns - the just added term (OBO::Core::Term) Args - the term id (string) and the term name (string) of term to be added Function - adds a term to this ontology =cut sub add_term_as_string { my $self = shift; if (@_) { my $term_id = shift; if (!$self->has_term_id($term_id)){ my $term_name = shift; $term_id || croak 'A term to be added to this ontology must have an ID.'; my $new_term = OBO::Core::Term->new(); $new_term->id($term_id); $new_term->name($term_name); $self->add_term($new_term); return $new_term; } else { warn "The term you tried to add ($term_id) is already in the ontology.\n"; } } else { croak 'To add a term, you need to provide both a term ID and a term name.'; } } =head2 add_instance_as_string Usage - $ontology->add_instance_as_string($instance_id, $instance_name) Returns - the just added instance (OBO::Core::Instance) Args - the instance id (string) and the instance name (string) of instance to be added Function - adds a instance to this ontology =cut sub add_instance_as_string { my $self = shift; if (@_) { my $instance_id = shift; if (!$self->has_instance_id($instance_id)){ my $instance_name = shift; $instance_id || croak 'A instance to be added to this ontology must have an ID.'; my $new_instance = OBO::Core::Instance->new(); $new_instance->id($instance_id); $new_instance->name($instance_name); $self->add_instance($new_instance); return $new_instance; } else { warn "The instance you tried to add ($instance_id) is already in the ontology.\n"; } } else { croak 'To add a instance, you need to provide both a instance ID and a instance name.'; } } =head2 add_relationship_type Usage - $ontology->add_relationship_type($relationship_type) Returns - the just added relationship type (OBO::Core::RelationshipType) Args - the relationship type to be added (OBO::Core::RelationshipType). The ID of the relationship type to be added must have already been defined. Function - adds a relationship type to this ontology =cut sub add_relationship_type { my ($self, $relationship_type) = @_; if ($relationship_type) { $self->{RELATIONSHIP_TYPES}->{$relationship_type->id()} = $relationship_type; return $relationship_type; # TODO Is it necessary to implement a set of relationship types? Maybe for get_relationship_types()? #$self->{RELATIONSHIP_TYPES_SET}->add($relationship_type); } else { croak 'Missing argument: add_relationship_type(relationship_type)'; } } =head2 add_relationship_type_as_string Usage - $ontology->add_relationship_type_as_string($relationship_type_id, $relationship_type_name) Returns - the just added relationship type (OBO::Core::RelationshipType) Args - the relationship type id (string) and the relationship type name (string) of the relationship type to be added Function - adds a relationship type to this ontology =cut sub add_relationship_type_as_string { my $self = shift; if (@_) { my $relationship_type_id = shift; $relationship_type_id || croak 'A relationship type to be added to this ontology must have an ID'; if (!$self->has_relationship_type_id($relationship_type_id)){ my $relationship_type_name = shift; my $new_relationship_type = OBO::Core::RelationshipType->new(); $new_relationship_type->id($relationship_type_id); $new_relationship_type->name($relationship_type_name); $self->add_relationship_type($new_relationship_type); return $new_relationship_type; } else { warn "The relationship type you tried to add ($relationship_type_id) is already in the ontology\n"; } } else { croak 'To add a relationship type, you need to provide both a relationship type ID and a relationship type name'; } } =head2 delete_term Usage - $ontology->delete_term($term) Returns - none Args - the term (OBO::Core::Term) to be deleted Function - deletes a term from this ontology Remark - the resulting ontology might be segmented, i.e., the deleted node might create an unconnected sub-ontology Remark - the term (OBO::Core::Term) still exits after removing it from this ontology =cut sub delete_term { my ($self, $term) = @_; if ($term) { $term->id() || croak 'The term to be deleted from this ontology does not have an ID.'; my $id = $term->id(); if (defined($id) && defined($self->{TERMS}->{$id})) { delete $self->{TERMS}->{$id}; $self->{TERMS_SET}->remove($term); # Delete the relationships: to its parents and children! my @outward = @{$self->get_relationships_by_source_term($term)}; my @inward = @{$self->get_relationships_by_target_term($term)}; foreach my $r (@outward, @inward){ $self->delete_relationship($r); } } } } =head2 delete_instance Usage - $ontology->delete_instance($instance) Returns - none Args - the instance (OBO::Core::Instance) to be deleted Function - deletes a instance from this ontology Remark - the instance (OBO::Core::Instance) still exits after removing it from this ontology =cut sub delete_instance { my ($self, $instance) = @_; if ($instance) { $instance->id() || croak 'The instance to be deleted from this ontology does not have an ID.'; my $id = $instance->id(); if (defined($id) && defined($self->{INSTANCES}->{$id})) { delete $self->{INSTANCES}->{$id}; #$self->{INSTANCES_SET}->remove($instance); # TODO Delete the relationships ($self->delete_relationship()): to its parents and children! } } } =head2 delete_relationship Usage - $ontology->delete_relationship($rel) Returns - none Args - the relationship (OBO::Core::Relationship) to be deleted Function - deletes a relationship from this ontology Remark - the relationship (OBO::Core::Relationship) still exits after removing it from this ontology =cut sub delete_relationship { my ($self, $relationship) = @_; if ($relationship) { $relationship->id() || croak 'The relationship to be deleted from this ontology does not have an ID.'; my $id = $relationship->id(); if (defined($id) && defined($self->{RELATIONSHIPS}->{$id})) { delete $self->{RELATIONSHIPS}->{$id}; my $head = $relationship->head(); my $type = $relationship->type(); my $tail = $relationship->tail(); delete $self->{TARGET_RELATIONSHIPS}->{$head}->{$type}->{$tail}; delete $self->{SOURCE_RELATIONSHIPS}->{$tail}->{$type}->{$head}; delete $self->{TARGET_SOURCE_RELATIONSHIPS}->{$tail}->{$head}->{$type}; #$self->{RELATIONSHIPS_SET}->remove($term); } } } =head2 has_term Usage - print $ontology->has_term($term) Returns - true or false Args - the term (OBO::Core::Term) to be tested Function - checks if the given term belongs to this ontology =cut sub has_term { my ($self, $term) = @_; #return (defined $term && defined($self->{TERMS}->{$term->id()})); # TODO Is this faster than: return defined $term && $self->{TERMS_SET}->contains($term); } =head2 has_instance Usage - print $ontology->has_instance($instance) Returns - true or false Args - the instance (OBO::Core::Instance) to be tested Function - checks if the given instance belongs to this ontology =cut sub has_instance { my ($self, $instance) = @_; return (defined $instance && defined($self->{INSTANCES}->{$instance->id()})); # TODO Check the INSTANCES_SET #$result = 1 if (defined($id) && defined($self->{INSTANCES}->{$id}) && $self->{INSTANCES_SET}->contains($instance)); } =head2 has_term_id Usage - print $ontology->has_term_id($term_id) Returns - true or false Args - the term id (string) to be tested Function - checks if the given term id corresponds to a term held by this ontology =cut sub has_term_id { my ($self, $term_id) = @_; return (defined $term_id && defined($self->{TERMS}->{$term_id})); # TODO Check the TERMS_SET #return (defined $term_id && defined($self->{TERMS}->{$term_id}) && $self->{TERMS_SET}->contains($self->get_term_by_id($term_id))); } =head2 has_instance_id Usage - print $ontology->has_instance_id($instance_id) Returns - true or false Args - the instance id (string) to be tested Function - checks if the given instance id corresponds to a instance held by this ontology =cut sub has_instance_id { my ($self, $instance_id) = @_; return (defined $instance_id && defined($self->{INSTANCES}->{$instance_id})); # TODO Check the INSTANCES_SET #return (defined $instance_id && defined($self->{INSTANCES}->{$instance_id}) && $self->{INSTANCES_SET}->contains($self->get_instance_by_id($instance_id))); } =head2 has_relationship_type Usage - print $ontology->has_relationship_type($relationship_type) Returns - true or false Args - the relationship type (OBO::Core::RelationshipType) to be tested Function - checks if the given relationship type belongs to this ontology =cut sub has_relationship_type { my ($self, $relationship_type) = @_; return (defined $relationship_type && defined($self->{RELATIONSHIP_TYPES}->{$relationship_type->id()})); } =head2 has_relationship_type_id Usage - print $ontology->has_relationship_type_id($relationship_type_id) Returns - true or false Args - the relationship type id (string) to be tested Function - checks if the given relationship type id corresponds to a relationship type held by this ontology =cut sub has_relationship_type_id { my ($self, $relationship_type_id) = @_; return (defined $relationship_type_id && defined($self->{RELATIONSHIP_TYPES}->{$relationship_type_id})); } =head2 has_relationship_id Usage - print $ontology->has_relationship_id($rel_id) Returns - true or false Args - the relationship id (string) to be tested Function - checks if the given relationship id corresponds to a relationship held by this ontology =cut sub has_relationship_id { my ($self, $id) = @_; return (defined $id && defined($self->{RELATIONSHIPS}->{$id})); } =head2 equals Usage - print $ontology->equals($another_ontology) Returns - either 1 (true) or 0 (false) Args - the ontology (OBO::Core::Ontology) to compare with Function - tells whether this ontology is equal to the parameter =cut sub equals { my $self = shift; my $result = 0; # TODO Implement this method croak 'Method: OBO::Core:Ontology::equals in not implemented yet, use OBO::Util::Ontolome meanwhile'; return $result; } =head2 get_terms Usage - $ontology->get_terms() or $ontology->get_terms("APO:I.*") or $ontology->get_terms("GO:012*") Returns - the terms held by this ontology as a reference to an array of OBO::Core::Term's Args - none or the regular expression for filtering the terms by id's Function - returns the terms held by this ontology =cut sub get_terms { my $self = shift; my @terms; if (@_) { foreach my $term (values(%{$self->{TERMS}})) { push @terms, $term if ($term->id() =~ /$_[0]/); } } else { #@terms = $self->{TERMS_SET}->get_set(); # TODO Is this faster than: @terms = values(%{$self->{TERMS}}); } return \@terms; } =head2 get_instances Usage - $ontology->get_instances() or $ontology->get_instances("APO:K.*") Returns - the instances held by this ontology as a reference to an array of OBO::Core::Instance's Args - none or the regular expression for filtering the instances by id's Function - returns the instances held by this ontology =cut sub get_instances { my $self = shift; my @instances; if (@_) { foreach my $instance (values(%{$self->{INSTANCES}})) { push @instances, $instance if ($instance->id() =~ /$_[0]/); } } else { @instances = values(%{$self->{INSTANCES}}); #@instances = $self->{INSTANCES_SET}->get_set(); # TODO This INSTANCES_SET was giving wrong results.... } return \@instances; } =head2 get_terms_sorted_by_id Usage - $ontology->get_terms_sorted_by_id() or $ontology->get_terms_sorted_by_id("APO:I.*") Returns - the terms held by this ontology as a reference to a sorted (by ID) array of OBO::Core::Term's Args - none or the regular expression for filtering the terms by id's Function - returns the terms held by this ontology, the terms are sorted by ID (using the Schwartzian Transform) =cut sub get_terms_sorted_by_id { my $self = shift; my @sorted_terms = __sort_by_id(sub {shift}, @{$self->get_terms(@_)}); return \@sorted_terms; } =head2 get_instances_sorted_by_id Usage - $ontology->get_instances_sorted_by_id() or $ontology->get_instances_sorted_by_id("APO:K.*") Returns - the instances held by this ontology as a reference to a sorted (by ID) array of OBO::Core::Instance's Args - none or the regular expression for filtering the instances by id's Function - returns the instances held by this ontology, the instances are sorted by ID (using the Schwartzian Transform) =cut sub get_instances_sorted_by_id { my $self = shift; my @sorted_instances = __sort_by_id(sub {shift}, @{$self->get_instances(@_)}); return \@sorted_instances; } =head2 get_terms_by_subnamespace Usage - $ontology->get_terms_by_subnamespace() or $ontology->get_terms_by_subnamespace("P") or or $ontology->get_terms_by_subnamespace("Pa") Returns - the terms held by this ontology corresponding to the requested subnamespace as a reference to an array of OBO::Core::Term's Args - none or the subnamespace: 'P', 'I', 'Pa', 'Ia' and so on. Function - returns the terms held by this ontology corresponding to the requested subnamespace =cut sub get_terms_by_subnamespace { my $self = shift; my $terms; if (@_) { my $is = $self->get_terms_idspace(); if (!defined $is) { croak 'The local ID space is not defined for this ontology.'; } else { $terms = $self->get_terms($is.':'.$_[0]); } } return $terms; } =head2 get_instances_by_subnamespace Usage - $ontology->get_instances_by_subnamespace() or $ontology->get_instances_by_subnamespace("K") or or $ontology->get_instances_by_subnamespace("Ka") Returns - the instances held by this ontology corresponding to the requested subnamespace as a reference to an array of OBO::Core::Instance's Args - none or the subnamespace: 'K', 'L', 'Ka', 'La' and so on. Function - returns the instances held by this ontology corresponding to the requested subnamespace =cut sub get_instances_by_subnamespace { my $self = shift; my $instances; if (@_) { my $is = $self->get_instances_idspace(); if (!defined $is) { croak 'The local ID space is not defined for this ontology.'; } else { $instances = $self->get_instances($is.':'.$_[0]); } } return $instances; } =head2 get_terms_by_subset Usage - $ontology->get_terms_by_subset("GO_SLIM") Returns - the terms held by this ontology belonging to the given subset as a reference to an array of OBO::Core::Term's Args - a subset name Function - returns the terms held by this ontology belonging to the requested subset =cut sub get_terms_by_subset { my ($self, $subset) = @_; my @terms; foreach my $term (values(%{$self->{TERMS}})) { foreach my $ss ($term->subset()) { push @terms, $term if ($ss =~ /$subset/); } } return \@terms; } =head2 get_instances_by_subset Usage - $ontology->get_instances_by_subset("INSTANCES_SLIM") Returns - the instances held by this ontology belonging to the given subset as a reference to an array of OBO::Core::Instance's Args - a subset name Function - returns the instances held by this ontology belonging to the requested subset =cut sub get_instances_by_subset { my ($self, $subset) = @_; my @instances; foreach my $instance (values(%{$self->{INSTANCES}})) { foreach my $ss ($instance->subset()) { push @instances, $instance if ($ss =~ /$subset/); } } return \@instances; } =head2 get_relationships Usage - $ontology->get_relationships() Returns - the relationships held by this ontology as a reference to an array of OBO::Core::Relationship's Args - none Function - returns the relationships held by this ontology =cut sub get_relationships { my $self = shift; my @relationships = values(%{$self->{RELATIONSHIPS}}); return \@relationships; } =head2 get_relationship_types Usage - $ontology->get_relationship_types() Returns - a reference to an array with the relationship types (OBO::Core::RelationshipType) held by this ontology Args - none Function - returns the relationship types held by this ontology =cut sub get_relationship_types { my $self = shift; my @relationship_types = values(%{$self->{RELATIONSHIP_TYPES}}); return \@relationship_types; } =head2 get_relationship_types_sorted_by_id Usage - $ontology->get_relationship_types_sorted_by_id() Returns - the relationship types held by this ontology as a reference to a sorted (by ID) array of OBO::Core::Term's Args - none or the regular expression for filtering the terms by id's Function - returns the relationship types held by this ontology, the relationship types are sorted by ID (using the Schwartzian Transform) =cut sub get_relationship_types_sorted_by_id { my $self = shift; my @sorted_relationship_types = __sort_by_id(sub {shift}, values(%{$self->{RELATIONSHIP_TYPES}})); return \@sorted_relationship_types; } =head2 get_term_local_neighbourhood Usage - $ontology->get_term_local_neighbourhood($term, $rel_type) Returns - the neighbourhood of a given term as a reference to an array with the relationships (OBO::Core::Relationship) 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 Function - returns the local neighbourhood of the given term as a reference to an array with the relationships (OBO::Core::Relationship) 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) =cut sub get_term_local_neighbourhood { my ($self, $term, $rel_type) = @_; return $self->get_relationships_by_source_term($term, $rel_type); } =head2 get_relationships_by_source_term Usage - $ontology->get_relationships_by_source_term($source_term, $rel_type) Returns - a reference to an array with the relationships (OBO::Core::Relationship) connecting the given term to its children 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 Function - returns the relationships associated to the given source term =cut sub get_relationships_by_source_term { my ($self, $term, $rel_type) = @_; my $result = OBO::Util::Set->new(); if ($term) { if ($rel_type) { my @rels = values(%{$self->{SOURCE_RELATIONSHIPS}->{$term}->{$rel_type}}); foreach my $rel (@rels) { $result->add($rel); } } else { my @hashes = values(%{$self->{SOURCE_RELATIONSHIPS}->{$term}}); foreach my $hash (@hashes) { my @rels = values %{$hash}; foreach my $rel (@rels) { $result->add($rel); } } } } my @arr = $result->get_set(); return \@arr; } =head2 get_relationships_by_target_term Usage - $ontology->get_relationships_by_target_term($target_term, $rel_type) Returns - a reference to an array with the relationships (OBO::Core::Relationship) connecting the given term to its parents 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 Function - returns the relationships associated to the given target term =cut sub get_relationships_by_target_term { my ($self, $term, $rel_type) = @_; my $result = OBO::Util::Set->new(); if ($term) { if ($rel_type) { my @rels = values(%{$self->{TARGET_RELATIONSHIPS}->{$term}->{$rel_type}}); foreach my $rel (@rels) { $result->add($rel); } } else { my @hashes = values(%{$self->{TARGET_RELATIONSHIPS}->{$term}}); foreach my $hash (@hashes) { my @rels = values %{$hash}; foreach my $rel (@rels) { $result->add($rel); } } } } my @arr = $result->get_set(); return \@arr; } =head2 get_term_by_id Usage - $ontology->get_term_by_id($id) Returns - the term (OBO::Core::Term) associated to the given ID Args - the term's ID (string) Function - returns the term associated to the given ID =cut sub get_term_by_id { my ($self, $id) = @_; return $self->{TERMS}->{$id}; } =head2 get_instance_by_id Usage - $ontology->get_instance_by_id($id) Returns - the instance (OBO::Core::Instance) associated to the given ID Args - the instance's ID (string) Function - returns the instance associated to the given ID =cut sub get_instance_by_id { my ($self, $id) = @_; return $self->{INSTANCES}->{$id}; } =head2 set_term_id Usage - $ontology->set_term_id($term, $new_term_id) Returns - the term (OBO::Core::Term) with its new ID Args - the term (OBO::Core::Term) and its new term's ID (string) Function - sets a new term ID for the given term =cut sub set_term_id { my ($self, $term, $new_term_id) = @_; if ($term && $new_term_id) { if ($self->has_term($term)) { if (!$self->has_term_id($new_term_id)) { $self->{TERMS_SET}->remove($term); my $old_id = $term->id(); $term->id($new_term_id); $self->{TERMS}->{$new_term_id} = $self->{TERMS}->{$old_id}; delete $self->{TERMS}->{$old_id}; $self->{TERMS_SET}->add($term); # Adapt the relationship ids of this term, e.g., APO:P0000001_is_a_APO:P0000002 => APO:P0000003_is_a_APO:P0000002 my @outward = @{$self->get_relationships_by_source_term($term)}; foreach my $r (@outward){ $self->delete_relationship($r); my $r_id = $r->id(); (my $new_r_id = $r_id) =~ s/^$old_id(_)/$new_term_id$1/; $r->id($new_r_id); $self->create_rel($term, $r->type(), $r->head()); } my @inward = @{$self->get_relationships_by_target_term($term)}; foreach my $r (@inward){ $self->delete_relationship($r); my $r_id = $r->id(); (my $new_r_id = $r_id) =~ s/(_)$old_id$/$1$new_term_id/; $r->id($new_r_id); $self->create_rel($r->tail(), $r->type(), $term); } return $self->{TERMS}->{$new_term_id}; } else { croak 'The given new ID (', $new_term_id, ') is already used by: ', $self->get_term_by_id($new_term_id)->name(); } } else { croak 'The term for which you want to modify its ID (', $new_term_id, ') is not in the ontology'; } } } =head2 set_instance_id Usage - $ontology->set_instance_id($instance, $new_id) Returns - the instance (OBO::Core::Instance) with its new ID Args - the instance (OBO::Core::Instance) and its new instance's ID (string) Function - sets a new instance ID for the given instance =cut sub set_instance_id { my ($self, $instance, $new_instance_id) = @_; if ($instance && $new_instance_id) { if ($self->has_instance($instance)) { if (!$self->has_instance_id($new_instance_id)) { my $old_id = $instance->id(); $instance->id($new_instance_id); $self->{INSTANCES}->{$new_instance_id} = $self->{INSTANCES}->{$old_id}; delete $self->{INSTANCES}->{$old_id}; # TODO Adapt the subtype relationship this instance: APO:K0000001_is_a_APO:P0000001 => APO:K0000011_is_a_APO:P0000001 return $self->{INSTANCES}->{$new_instance_id}; } else { croak 'The given new ID (', $new_instance_id, ') is already used by: ', $self->get_instance_by_id($new_instance_id)->name(); } } else { croak 'The instance for which you want to modify its ID (', $new_instance_id, ') is not in the ontology'; } } } =head2 get_relationship_type_by_id Usage - $ontology->get_relationship_type_by_id($id) Returns - the relationship type (OBO::Core::RelationshipType) associated to the given id Args - the relationship type's id (string) Function - returns the relationship type associated to the given id =cut sub get_relationship_type_by_id { my ($self, $id) = @_; return $self->{RELATIONSHIP_TYPES}->{$id} if ($id); } =head2 get_term_by_name Usage - $ontology->get_term_by_name($name) Returns - the term (OBO::Core::Term) associated to the given name Args - the term's name (string) Function - returns the term associated to the given name Remark - the argument (string) is case sensitive =cut sub get_term_by_name { my ($self, $name) = ($_[0], $_[1]); my $result; if ($name) { foreach my $term (@{$self->get_terms()}) { # return the exact occurrence $result = $term, last if (defined ($term->name()) && ($term->name() eq $name)); } } return $result; } =head2 get_instance_by_name Usage - $ontology->get_instance_by_name($name) Returns - the instance (OBO::Core::Instance) associated to the given name Args - the instance's name (string) Function - returns the instance associated to the given name Remark - the argument (string) is case sensitive =cut sub get_instance_by_name { my ($self, $name) = ($_[0], $_[1]); my $result; if ($name) { foreach my $instance (@{$self->get_instances()}) { # return the exact occurrence $result = $instance, last if (defined ($instance->name()) && ($instance->name() eq $name)); } } return $result; } =head2 get_term_by_name_or_synonym Usage - $ontology->get_term_by_name_or_synonym($name, $scope) Returns - the term (OBO::Core::Term) associated to the given name or synonym (given its scope, EXACT by default) Args - the term's name or synonym (string) and optionally the scope of the synonym (EXACT by default) Function - returns the term associated to the given name or synonym (given its scope, EXACT by default) Remark - this function should be carefully used since among ontologies there may be homonyms at the level of the synonyms (e.g. genes) Remark - the argument (string) is case sensitive =cut sub get_term_by_name_or_synonym { my ($self, $name_or_synonym, $scope) = ($_[0], $_[1], $_[2]); my $result; if ($name_or_synonym) { $scope = $scope || "EXACT"; foreach my $term (@{$self->get_terms()}) { # return the exact occurrence # Look up for the 'name' my $t_name = $term->name(); if (defined ($t_name) && (lc($t_name) eq $name_or_synonym)) { return $term; } # Look up for its synonyms (and optinal scope) foreach my $syn ($term->synonym_set()){ my $s_text = $syn->def()->text(); if (($scope eq "ANY" && $s_text eq $name_or_synonym) || ($syn->scope() eq $scope && $s_text eq $name_or_synonym)) { return $term; } } } } } =head2 get_instance_by_name_or_synonym Usage - $ontology->get_instance_by_name_or_synonym($name, $scope) Returns - the instance (OBO::Core::Instance) associated to the given name or synonym (given its scope, EXACT by default) Args - the instance's name or synonym (string) and optionally the scope of the synonym (EXACT by default) Function - returns the instance associated to the given name or synonym (given its scope, EXACT by default) Remark - this function should be carefully used since among ontologies there may be homonyms at the level of the synonyms (e.g. locations) Remark - the argument (string) is case sensitive =cut sub get_instance_by_name_or_synonym { my ($self, $name_or_synonym, $scope) = ($_[0], $_[1], $_[2]); my $result; if ($name_or_synonym) { $scope = $scope || "EXACT"; foreach my $instance (@{$self->get_instances()}) { # return the exact occurrence # Look up for the 'name' my $t_name = $instance->name(); if (defined ($t_name) && (lc($t_name) eq $name_or_synonym)) { return $instance; } # Look up for its synonyms (and optinal scope) foreach my $syn ($instance->synonym_set()){ my $s_text = $syn->def()->text(); if (($scope eq "ANY" && $s_text eq $name_or_synonym) || ($syn->scope() eq $scope && $s_text eq $name_or_synonym)) { return $instance; } } } } } =head2 get_terms_by_name Usage - $ontology->get_terms_by_name($name) Returns - the term set (OBO::Util::TermSet) with all the terms (OBO::Core::Term) having $name in their names Args - the term name (string) Function - returns the terms having $name in their names =cut sub get_terms_by_name { my ($self, $name) = ($_[0], lc($_[1])); my $result; if ($name) { $result = OBO::Util::TermSet->new(); my @terms = @{$self->get_terms()}; # NB. the following two lines are equivalent to the 'for' loop #my @found_terms = grep {lc($_->name()) =~ /$name/} @terms; #$result->add_all(@found_terms); foreach my $term (@terms) { # return the all the occurrences $result->add($term) if (defined ($term->name()) && lc($term->name()) =~ /$name/); } } return $result; } =head2 get_instances_by_name Usage - $ontology->get_instances_by_name($name) Returns - the instance set (OBO::Util::InstanceSet) with all the instances (OBO::Core::Instance) having $name in their names Args - the instance name (string) Function - returns the instances having $name in their names =cut sub get_instances_by_name { my ($self, $name) = ($_[0], lc($_[1])); my $result; if ($name) { $result = OBO::Util::InstanceSet->new(); my @instances = @{$self->get_instances()}; # NB. the following two lines are equivalent to the 'for' loop #my @found_instances = grep {lc($_->name()) =~ /$name/} @instances; #$result->add_all(@found_instances); foreach my $instance (@instances) { # return the all the occurrences $result->add($instance) if (defined ($instance->name()) && lc($instance->name()) =~ /$name/); } } return $result; } =head2 get_relationship_types_by_name Usage - $ontology->get_relationship_types_by_name($name) Returns - the relationship types set (OBO::Util::RelationshipTypeSet) with all the relationship types (OBO::Core::RelationshipType) having $name in their names Args - the relationship type name (string) Function - returns the relationship type having $name in their names =cut sub get_relationship_types_by_name { my ($self, $name) = ($_[0], lc($_[1])); my $result; if ($name) { $result = OBO::Util::RelationshipTypeSet->new(); my @relationship_types = @{$self->get_relationship_types()}; # NB. the following two lines are equivalent to the 'for' loop #my @found_relationship_types = grep {lc($_->name()) =~ /$name/} @relationship_types; #$result->add_all(@found_relationship_types); foreach my $relationship_type (@relationship_types) { # return the all the occurrences $result->add($relationship_type) if (defined ($relationship_type->name()) && lc($relationship_type->name()) =~ /$name/); } } return $result; } =head2 get_relationship_type_by_name Usage - $ontology->get_relationship_type_by_name($name) Returns - the relationship type (OBO::Core::RelationshipType) associated to the given name Args - the relationship type's name (string) Function - returns the relationship type associated to the given name =cut sub get_relationship_type_by_name { my ($self, $name) = ($_[0], lc($_[1])); my $result; if ($name) { foreach my $rel_type (@{$self->get_relationship_types()}) { # return the exact occurrence $result = $rel_type, last if (defined ($rel_type->name()) && (lc($rel_type->name()) eq $name)); } } return $result; } =head2 add_relationship Usage - $ontology->add_relationship($relationship) Returns - none Args - the relationship (OBO::Core::Relationship) to be added between two existing terms or two relationship types Function - adds a relationship between either two terms or two relationship types. Remark - If the terms or relationship types bound by this relationship are not yet in the ontology, they will be added 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) =cut sub add_relationship { my ($self, $relationship) = @_; my $rel_id = $relationship->id(); my $rel_type = $relationship->type(); $rel_id || croak 'The relationship to be added to this ontology does not have an ID'; $rel_type || croak 'The relationship to be added to this ontology does not have an TYPE'; $self->{RELATIONSHIPS}->{$rel_id} = $relationship; # # Are the target and source elements (term or relationship type) connected by $relationship already in this ontology? if not, add them. # my $r = $self->{RELATIONSHIPS}->{$rel_id}; my $target_element = $r->head(); my $source_element = $r->tail(); if (eval { $target_element->isa('OBO::Core::Term') } && eval { $source_element->isa('OBO::Core::Term') }) { $self->has_term($target_element) || $self->add_term($target_element); $self->has_term($source_element) || $self->add_term($source_element); } elsif (eval { $target_element->isa('OBO::Core::RelationshipType') } && eval { $source_element->isa('OBO::Core::RelationshipType') }) { $self->has_relationship_type($target_element) || $self->add_relationship_type($target_element); $self->has_relationship_type($source_element) || $self->add_relationship_type($source_element); } 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}? $self->has_term($target_element) || $self->add_term($target_element); $self->has_instance($source_element) || $self->add_instance($source_element); } 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}? $self->has_instance($target_element) || $self->add_instance($target_element); $self->has_instance($source_element) || $self->add_instance($source_element); } else { croak "An unrecognized object type (nor a Term, nor a RelationshipType) was found as part of the relationship with ID: '", $rel_id, "'"; } # # add the relationship type # if (!$self->has_relationship_type_id($rel_type) ){ my $new_rel_type = OBO::Core::RelationshipType->new(); $new_rel_type->id($rel_type); $self->{RELATIONSHIP_TYPES}->{$rel_type} = $new_rel_type; } # for getting children and parents my $head = $relationship->head(); my $type = $relationship->type(); my $tail = $relationship->tail(); $self->{TARGET_RELATIONSHIPS}->{$head}->{$type}->{$tail} = $relationship; $self->{SOURCE_RELATIONSHIPS}->{$tail}->{$type}->{$head} = $relationship; $self->{TARGET_SOURCE_RELATIONSHIPS}->{$tail}->{$head}->{$type} = $relationship; } =head2 get_relationship_by_id Usage - print $ontology->get_relationship_by_id() Returns - the relationship (OBO::Core::Relationship) associated to the given id Args - the relationship id (string) Function - returns the relationship associated to the given relationship id =cut sub get_relationship_by_id { my ($self, $id) = @_; return $self->{RELATIONSHIPS}->{$id}; } =head2 create_rel Usage - $ontology->create_rel->($tail, $type, $head) Returns - the OBO::Core::Ontology object Args - an OBO::Core::(Term|Relationship) object, a relationship type string (e.g. 'is_a'), and an OBO::Core::(Term|Relationship) object, Function - creates and adds a new relationship to this ontology =cut sub create_rel { my $self = shift; my($tail, $type, $head) = @_; croak "Not a valid relationship type: '", $type, "'" unless($self->{RELATIONSHIP_TYPES}->{$type}); if ($tail && $head) { my $id = $tail->id().'_'.$type.'_'.$head->id(); if ($self->has_relationship_id($id)) { #cluck 'The following rel ID already exists in the ontology: ', $id; # Implement a RelationshipSet? my $relationship = $self->get_relationship_by_id($id); $self->{TARGET_RELATIONSHIPS}->{$head}->{$type}->{$tail} = $relationship; $self->{SOURCE_RELATIONSHIPS}->{$tail}->{$type}->{$head} = $relationship; $self->{TARGET_SOURCE_RELATIONSHIPS}->{$tail}->{$head}->{$type} = $relationship; } else { my $rel = OBO::Core::Relationship->new(); $rel->type($type); $rel->link($tail, $head); $rel->id($id); $self->add_relationship($rel); } } else { croak 'To create a relationship, you must provide both a tail and a head object!'; } return $self; } =head2 get_child_terms Usage - $ontology->get_child_terms($term) Returns - a reference to an array with the child terms (OBO::Core::Term) of the given term Args - the term (OBO::Core::Term) for which the children will be found Function - returns the child terms of the given term =cut sub get_child_terms { my ($self, $term) = @_; my $result = OBO::Util::TermSet->new(); if ($term) { my @hashes = values(%{$self->{TARGET_RELATIONSHIPS}->{$term}}); foreach my $hash (@hashes) { my @rels = values %{$hash}; foreach my $rel (@rels) { $result->add($rel->tail()); } } } my @arr = $result->get_set(); return \@arr; } =head2 get_parent_terms Usage - $ontology->get_parent_terms($term) Returns - a reference to an array with the parent terms (OBO::Core::Term) of the given term Args - the term (OBO::Core::Term) for which the parents will be found Function - returns the parent terms of the given term =cut sub get_parent_terms { my ($self, $term) = @_; my $result = OBO::Util::TermSet->new(); if ($term) { my @hashes = values(%{$self->{SOURCE_RELATIONSHIPS}->{$term}}); foreach my $hash (@hashes) { my @rels = values %{$hash}; foreach my $rel (@rels) { $result->add($rel->head()); } } } my @arr = $result->get_set(); return \@arr; } =head2 get_head_by_relationship_type Usage - $ontology->get_head_by_relationship_type($term, $relationship_type) or $ontology->get_head_by_relationship_type($rel_type, $relationship_type) 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 Args - the term (OBO::Core::Term) or relationship type (OBO::Core::RelationshipType) and the pointing relationship type (OBO::Core::RelationshipType) Function - returns the terms or relationship types pointed out by the relationship of the given type =cut sub get_head_by_relationship_type { my ($self, $element, $relationship_type) = @_; # Performance improvement my @heads; if ($element && $relationship_type) { my $relationship_type_id = $relationship_type->id(); my @hashes = values(%{$self->{SOURCE_RELATIONSHIPS}->{$element}}); foreach my $hash (@hashes) { my @rels = values %{$hash}; foreach my $rel (@rels) { push @heads, $rel->head() if ($rel->type() eq $relationship_type_id); #Fix? push @heads, $rel->head() if ($rel->type() eq $relationship_type->name()); } } } return \@heads; # # my $result = OBO::Util::Set->new(); # if ($element && $relationship_type) { # my @rels = values(%{$self->{SOURCE_RELATIONSHIPS}->{$element}}); # foreach my $rel (@rels) { # $result->add($rel->head()) if ($rel->type() eq $relationship_type->id()); # } # } # my @arr = $result->get_set(); # return \@arr; } =head2 get_tail_by_relationship_type Usage - $ontology->get_tail_by_relationship_type($term, $relationship_type) or $ontology->get_tail_by_relationship_type($rel_type, $relationship_type) 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 Args - the term (OBO::Core::Term) or relationship type (OBO::Core::RelationshipType) and the relationship type (OBO::Core::RelationshipType) Function - returns the terms or relationship types pointing out the given term by means of the given relationship type =cut sub get_tail_by_relationship_type { # Performance improvement my ($self, $element, $relationship_type) = @_; my @tails; if ($element && $relationship_type) { my $relationship_type_id = $relationship_type->id(); my @hashes = values(%{$self->{TARGET_RELATIONSHIPS}->{$element}}); foreach my $hash (@hashes) { my @rels = values %{$hash}; foreach my $rel (@rels) { push @tails, $rel->tail() if ($rel->type() eq $relationship_type_id); } } } return \@tails; # # my $self = shift; # my $result = OBO::Util::Set->new(); # if (@_) { # my $element = shift; # my $relationship_type = shift; # my @rels = values(%{$self->{TARGET_RELATIONSHIPS}->{$element}}); # foreach my $rel (@rels) { # $result->add($rel->tail()) if ($rel->type() eq $relationship_type->id()); # } # } # my @arr = $result->get_set(); # return \@arr; } =head2 get_root_terms Usage - $ontology->get_root_terms() Returns - the root term(s) held by this ontology (as a reference to an array of OBO::Core::Term's) Args - none Function - returns the root term(s) held by this ontology =cut sub get_root_terms { my $self = shift; # TODO Consider the addition of one extra argument to request the root terms filtering out the obsolete ones... my @roots = (); my $term_set = OBO::Util::TermSet->new(); $term_set->add_all(values(%{$self->{TERMS}})); my @arr = $term_set->get_set(); while ($term_set->size() > 0){ my $term = pop @arr; my @hashes = values(%{$self->{SOURCE_RELATIONSHIPS}->{$term}}); if ($#hashes == -1) { # if there are no parents push @roots, $term; # it is a root term $term_set->remove($term); } else { # it is NOT a root term my @queue = ($term); while (scalar(@queue) > 0) { my $unqueued = shift @queue; my $rcode = $term_set->remove($unqueued); # remove the nodes that need not be visited my @children = @{$self->get_child_terms($unqueued)}; @queue = (@queue, @children); } @arr = $term_set->get_set(); } } return \@roots; } =head2 get_number_of_terms Usage - $ontology->get_number_of_terms() Returns - the number of terms held by this ontology Args - none Function - returns the number of terms held by this ontology =cut sub get_number_of_terms { my $self = shift; return scalar values(%{$self->{TERMS}}); } =head2 get_number_of_instances Usage - $ontology->get_number_of_instances() Returns - the number of instances held by this ontology Args - none Function - returns the number of instances held by this ontology =cut sub get_number_of_instances { my $self = shift; return scalar values(%{$self->{INSTANCES}}); } =head2 get_number_of_relationships Usage - $ontology->get_number_of_relationships() Returns - the number of relationships held by this ontology Args - none Function - returns the number of relationships held by this ontology =cut sub get_number_of_relationships { my $self = shift; return scalar values(%{$self->{RELATIONSHIPS}}); } =head2 get_number_of_relationship_types Usage - $ontology->get_number_of_relationship_types() Returns - the number of relationship types held by this ontology Args - none Function - returns the number of relationship types held by this ontology =cut sub get_number_of_relationship_types { my $self = shift; return scalar values(%{$self->{RELATIONSHIP_TYPES}}); } =head2 export2obo See - OBO::Core::Ontology::export() =cut sub export2obo { my ($self, $output_file_handle, $error_file_handle) = @_; ####################################################################### # # preambule: OBO header tags # ####################################################################### print $output_file_handle "format-version: 1.4\n"; my $data_version = $self->data_version(); print $output_file_handle 'data-version:', $data_version, "\n" if ($data_version); my $ontology_id_space = $self->id(); print $output_file_handle 'ontology:', $ontology_id_space, "\n" if ($ontology_id_space); chomp(my $local_date = __date()); # `date '+%d:%m:%Y %H:%M'` # date: 11:05:2008 12:52 print $output_file_handle 'date: ', (defined $self->date())?$self->date():$local_date, "\n"; my $saved_by = $self->saved_by(); print $output_file_handle 'saved-by: ', $saved_by, "\n" if (defined $saved_by); print $output_file_handle "auto-generated-by: ONTO-PERL $VERSION\n"; # import foreach my $import (sort {lc($a) cmp lc($b)} $self->imports()->get_set()) { print $output_file_handle 'import: ', $import, "\n"; } # subsetdef foreach my $subsetdef (sort {lc($a->name()) cmp lc($b->name())} $self->subset_def_map()->values()) { print $output_file_handle 'subsetdef: ', $subsetdef->as_string(), "\n"; } # synonyntypedef foreach my $st (sort {lc($a->name()) cmp lc($b->name())} $self->synonym_type_def_set()->get_set()) { print $output_file_handle 'synonymtypedef: ', $st->as_string(), "\n"; } # idspace's foreach my $idspace ($self->idspaces()->get_set()) { print $output_file_handle 'idspace: ', $idspace->as_string(), "\n"; } # default_namespace my $dns = $self->default_namespace(); print $output_file_handle 'default-namespace: ', $dns, "\n" if (defined $dns); # remark's foreach my $remark ($self->remarks()->get_set()) { print $output_file_handle 'remark: ', $remark, "\n"; } # treat-xrefs-as-equivalent foreach my $id_space_xref_eq (sort {lc($a) cmp lc($b)} $self->treat_xrefs_as_equivalent()->get_set()) { print $output_file_handle 'treat-xrefs-as-equivalent: ', $id_space_xref_eq, "\n"; } ####################################################################### # # terms # ####################################################################### my @all_terms = @{$self->get_terms_sorted_by_id()}; foreach my $term (@all_terms) { # # [Term] # print $output_file_handle "\n[Term]"; # # id # print $output_file_handle "\nid: ", $term->id(); # # is_anonymous # print $output_file_handle "\nis_anonymous: true" if ($term->is_anonymous()); # # name # if (defined $term->name()) { # from OBO 1.4, the name is not mandatory anymore print $output_file_handle "\nname: ", $term->name(); } # # namespace # foreach my $ns ($term->namespace()) { print $output_file_handle "\nnamespace: ", $ns; } # # alt_id # foreach my $alt_id ($term->alt_id()->get_set()) { print $output_file_handle "\nalt_id: ", $alt_id; } # # builtin # print $output_file_handle "\nbuiltin: true" if ($term->builtin()); # # property_value # my @property_values = sort {$a->id() cmp $b->id()} $term->property_value()->get_set(); foreach my $value (@property_values) { if (defined $value->head()->instance_of()) { print $output_file_handle "\nproperty_value: ".$value->type().' "'.$value->head()->id().'" '.$value->head()->instance_of()->id(); } else { print $output_file_handle "\nproperty_value: ".$value->type().' '.$value->head()->id(); } } # # def # # QUICK FIX due to some odd files (e.g. IntAct data) if (defined $term->def()->text()) { my $def_as_string = $term->def_as_string(); $def_as_string =~ s/\n+//g; $def_as_string =~ s/\r+//g; $def_as_string =~ s/\t+//g; print $output_file_handle "\ndef: ", $def_as_string; } # # comment # print $output_file_handle "\ncomment: ", $term->comment() if (defined $term->comment()); # # subset # foreach my $sset_name ($term->subset()) { if ($self->subset_def_map()->contains_key($sset_name)) { print $output_file_handle "\nsubset: ", $sset_name; } else { print $error_file_handle "\nThe term ", $term->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n"; } } # # synonym # my @sorted_defs = map { $_->[0] } # restore original values sort { $a->[1] cmp $b->[1] } # sort map { [$_, lc($_->def()->text())] } # transform: value, sortkey $term->synonym_set(); foreach my $synonym (@sorted_defs) { my $stn = $synonym->synonym_type_name(); if (defined $stn) { print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$stn.' '.$synonym->def()->dbxref_set_as_string(); } else { print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$synonym->def()->dbxref_set_as_string(); } } # # xref # my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $term->xref_set_as_string()); foreach my $xref (@sorted_xrefs) { print $output_file_handle "\nxref: ", $xref->as_string(); } # # is_a # my $rt = $self->get_relationship_type_by_id('is_a'); if (defined $rt) { my %saw_is_a; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) { my $is_a_txt = "\nis_a: ".$head->id(); my $head_name = $head->name(); $is_a_txt .= ' ! '.$head_name if (defined $head_name); print $output_file_handle $is_a_txt; } } # # intersection_of (at least 2 entries) # foreach my $tr ($term->intersection_of()) { my $tr_head = $tr->head(); my $tr_type = $tr->type(); my $intersection_of_name = $tr_head->name(); my $intersection_of_txt = "\nintersection_of: "; $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil'); $intersection_of_txt .= $tr_head->id(); $intersection_of_txt .= ' ! '.$intersection_of_name if (defined $intersection_of_name); print $output_file_handle $intersection_of_txt; } # # union_of (at least 2 entries) # foreach my $tr ($term->union_of()) { print $output_file_handle "\nunion_of: ", $tr; } # # disjoint_from # foreach my $disjoint_term_id ($term->disjoint_from()) { my $disjoint_from_txt = "\ndisjoint_from: ".$disjoint_term_id; my $dt = $self->get_term_by_id($disjoint_term_id); my $dt_name = $dt->name() if (defined $dt); $disjoint_from_txt .= ' ! '.$dt_name if (defined $dt_name); print $output_file_handle $disjoint_from_txt; } # # relationship # my %saw1; my @sorted_rel_types = @{$self->get_relationship_types_sorted_by_id()}; foreach my $rt (grep (!$saw1{$_}++, @sorted_rel_types)) { # use this foreach-line if there are duplicated rel's my $rt_id = $rt->id(); if ($rt_id ne 'is_a') { # is_a is printed above my %saw2; my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw2{$_}++, @sorted_heads)) { # use this foreach-line if there are duplicated rel's my $relationship_txt = "\nrelationship: ".$rt_id.' '.$head->id(); my $relationship_name = $head->name(); $relationship_txt .= ' ! '.$relationship_name if (defined $relationship_name); print $output_file_handle $relationship_txt; } } } # # created_by # print $output_file_handle "\ncreated_by: ", $term->created_by() if (defined $term->created_by()); # # creation_date # print $output_file_handle "\ncreation_date: ", $term->creation_date() if (defined $term->creation_date()); # # modified_by # print $output_file_handle "\nmodified_by: ", $term->modified_by() if (defined $term->modified_by()); # # modification_date # print $output_file_handle "\nmodification_date: ", $term->modification_date() if (defined $term->modification_date()); # # is_obsolete # print $output_file_handle "\nis_obsolete: true" if ($term->is_obsolete()); # # replaced_by # foreach my $replaced_by ($term->replaced_by()->get_set()) { print $output_file_handle "\nreplaced_by: ", $replaced_by; } # # consider # foreach my $consider ($term->consider()->get_set()) { print $output_file_handle "\nconsider: ", $consider; } # # end # print $output_file_handle "\n"; } ####################################################################### # # instances # ####################################################################### my @all_instances = @{$self->get_instances_sorted_by_id()}; foreach my $instance (@all_instances) { # # [Instance] # print $output_file_handle "\n[Instance]"; # # id # print $output_file_handle "\nid: ", $instance->id(); # # is_anonymous # print $output_file_handle "\nis_anonymous: true" if ($instance->is_anonymous()); # # name # if (defined $instance->name()) { # from OBO 1.4, the name is not mandatory anymore print $output_file_handle "\nname: ", $instance->name(); } # # namespace # foreach my $ns ($instance->namespace()) { print $output_file_handle "\nnamespace: ", $ns; } # # alt_id # foreach my $alt_id ($instance->alt_id()->get_set()) { print $output_file_handle "\nalt_id: ", $alt_id; } # # builtin # print $output_file_handle "\nbuiltin: true" if ($instance->builtin()); # # comment # print $output_file_handle "\ncomment: ", $instance->comment() if (defined $instance->comment()); # # subset # foreach my $sset_name ($instance->subset()) { if ($self->subset_def_map()->contains_key($sset_name)) { print $output_file_handle "\nsubset: ", $sset_name; } else { print $error_file_handle "\nThe instance ", $instance->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n"; } } # # synonym # my @sorted_defs = map { $_->[0] } # restore original values sort { $a->[1] cmp $b->[1] } # sort map { [$_, lc($_->def()->text())] } # transform: value, sortkey $instance->synonym_set(); foreach my $synonym (@sorted_defs) { my $stn = $synonym->synonym_type_name(); if (defined $stn) { print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$stn.' '.$synonym->def()->dbxref_set_as_string(); } else { print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$synonym->def()->dbxref_set_as_string(); } } # # xref # my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $instance->xref_set_as_string()); foreach my $xref (@sorted_xrefs) { print $output_file_handle "\nxref: ", $xref->as_string(); } # # instance_of # my $class = $instance->instance_of(); if ($class) { my $instance_of_txt = "\ninstance_of: ".$class->id(); my $class_name = $class->name(); $instance_of_txt .= ' ! '.$class_name if (defined $class_name); print $output_file_handle $instance_of_txt; } # # property_value # my @property_values = sort {$a->id() cmp $b->id()} $instance->property_value()->get_set(); foreach my $value (@property_values) { # TODO Finalise this implementation print $output_file_handle "\nproperty_value: ".$value->type().' '.$value->head()->id(); } # # intersection_of (at least 2 entries) # foreach my $tr ($instance->intersection_of()) { my $tr_head = $tr->head(); my $tr_type = $tr->type(); my $intersection_of_name = $tr_head->name(); my $intersection_of_txt = "\nintersection_of: "; $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil'); $intersection_of_txt .= $tr_head->id(); $intersection_of_txt .= ' ! '.$intersection_of_name if (defined $intersection_of_name); print $output_file_handle $intersection_of_txt; } # # union_of (at least 2 entries) # foreach my $tr ($instance->union_of()) { print $output_file_handle "\nunion_of: ", $tr; } # # disjoint_from # foreach my $disjoint_instance_id ($instance->disjoint_from()) { my $disjoint_from_txt = "\ndisjoint_from: ".$disjoint_instance_id; my $dt = $self->get_instance_by_id($disjoint_instance_id); my $dt_name = $dt->name() if (defined $dt); $disjoint_from_txt .= ' ! '.$dt_name if (defined $dt_name); print $output_file_handle $disjoint_from_txt; } # # relationship # my %saw1; my @sorted_rel_types = @{$self->get_relationship_types_sorted_by_id()}; foreach my $rt (grep (!$saw1{$_}++, @sorted_rel_types)) { # use this foreach-line if there are duplicated rel's my $rt_id = $rt->id(); if ($rt_id ne 'is_a') { # is_a is printed above my %saw2; my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($instance, $rt)}); foreach my $head (grep (!$saw2{$_}++, @sorted_heads)) { # use this foreach-line if there are duplicated rel's my $relationship_txt = "\nrelationship: ".$rt_id.' '.$head->id(); my $relationship_name = $head->name(); $relationship_txt .= ' ! '.$relationship_name if (defined $relationship_name); print $output_file_handle $relationship_txt; } } } # # created_by # print $output_file_handle "\ncreated_by: ", $instance->created_by() if (defined $instance->created_by()); # # creation_date # print $output_file_handle "\ncreation_date: ", $instance->creation_date() if (defined $instance->creation_date()); # # modified_by # print $output_file_handle "\nmodified_by: ", $instance->modified_by() if (defined $instance->modified_by()); # # modification_date # print $output_file_handle "\nmodification_date: ", $instance->modification_date() if (defined $instance->modification_date()); # # is_obsolete # print $output_file_handle "\nis_obsolete: true" if ($instance->is_obsolete()); # # replaced_by # foreach my $replaced_by ($instance->replaced_by()->get_set()) { print $output_file_handle "\nreplaced_by: ", $replaced_by; } # # consider # foreach my $consider ($instance->consider()->get_set()) { print $output_file_handle "\nconsider: ", $consider; } # # end # print $output_file_handle "\n"; } ####################################################################### # # relationship types # ####################################################################### foreach my $relationship_type ( @{$self->get_relationship_types_sorted_by_id()} ) { print $output_file_handle "\n[Typedef]"; # # id # print $output_file_handle "\nid: ", $relationship_type->id(); # # is_anonymous # print $output_file_handle "\nis_anonymous: true" if ($relationship_type->is_anonymous()); # # name # my $relationship_type_name = $relationship_type->name(); if (defined $relationship_type_name) { print $output_file_handle "\nname: ", $relationship_type_name; } # # namespace # foreach my $ns ($relationship_type->namespace()) { print $output_file_handle "\nnamespace: ", $ns; } # # alt_id # foreach my $alt_id ($relationship_type->alt_id()->get_set()) { print $output_file_handle "\nalt_id: ", $alt_id; } # # builtin # print $output_file_handle "\nbuiltin: true" if ($relationship_type->builtin() == 1); # # def # print $output_file_handle "\ndef: ", $relationship_type->def_as_string() if (defined $relationship_type->def()->text()); # # comment # print $output_file_handle "\ncomment: ", $relationship_type->comment() if (defined $relationship_type->comment()); # # subset # foreach my $sset_name ($relationship_type->subset()) { if ($self->subset_def_map()->contains_key($sset_name)) { print $output_file_handle "\nsubset: ", $sset_name; } else { 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"; } } # # synonym # foreach my $synonym ($relationship_type->synonym_set()) { print $output_file_handle "\nsynonym: \"".$synonym->def()->text().'" '.$synonym->scope().' '.$synonym->def()->dbxref_set_as_string(); } # # xref # my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $relationship_type->xref_set_as_string()); foreach my $xref (@sorted_xrefs) { print $output_file_handle "\nxref: ", $xref->as_string(); } # # domain # foreach my $domain ($relationship_type->domain()->get_set()) { print $output_file_handle "\ndomain: ", $domain; } # # range # foreach my $range ($relationship_type->range()->get_set()) { print $output_file_handle "\nrange: ", $range; } print $output_file_handle "\nis_anti_symmetric: true" if ($relationship_type->is_anti_symmetric() == 1); print $output_file_handle "\nis_cyclic: true" if ($relationship_type->is_cyclic() == 1); print $output_file_handle "\nis_reflexive: true" if ($relationship_type->is_reflexive() == 1); print $output_file_handle "\nis_symmetric: true" if ($relationship_type->is_symmetric() == 1); print $output_file_handle "\nis_transitive: true" if ($relationship_type->is_transitive() == 1); # # is_a: TODO missing function to retrieve the rel types # my $rt = $self->get_relationship_type_by_id('is_a'); if (defined $rt) { my @heads = @{$self->get_head_by_relationship_type($relationship_type, $rt)}; foreach my $head (@heads) { my $head_name = $head->name(); if (defined $head_name) { print $output_file_handle "\nis_a: ", $head->id(), ' ! ', $head_name; } else { print $output_file_handle "\nis_a: ", $head->id(); } } } # # intersection_of (at least 2 entries) # foreach my $tr ($relationship_type->intersection_of()) { my $tr_head = $tr->head(); my $tr_type = $tr->type(); my $intersection_of_name = $tr_head->name(); my $intersection_of_txt = "\nintersection_of: "; $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil'); $intersection_of_txt .= $tr_head->id(); $intersection_of_txt .= ' ! '.$intersection_of_name if (defined $intersection_of_name); print $output_file_handle $intersection_of_txt; } # # union_of (at least 2 entries) # foreach my $tr ($relationship_type->union_of()) { print $output_file_handle "\nunion_of: ", $tr; } # # disjoint_from # foreach my $disjoint_relationship_type_id ($relationship_type->disjoint_from()) { my $disjoint_from_txt = "\ndisjoint_from: ".$disjoint_relationship_type_id; my $dt = $self->get_relationship_type_by_id($disjoint_relationship_type_id); my $dt_name = $dt->name() if (defined $dt); $disjoint_from_txt .= ' ! '.$dt_name if (defined $dt_name); print $output_file_handle $disjoint_from_txt; } # # inverse_of # my $ir = $relationship_type->inverse_of(); if (defined $ir) { my $inv_name = $ir->name(); if (defined $inv_name) { print $output_file_handle "\ninverse_of: ", $ir->id(), ' ! ', $inv_name; } else { print $output_file_handle "\ninverse_of: ", $ir->id(); } } # # transitive_over # foreach my $transitive_over ($relationship_type->transitive_over()->get_set()) { print $output_file_handle "\ntransitive_over: ", $transitive_over; } # # holds_over_chain # my @sorted_hocs = map { $_->[0] } # restore original values sort { $a->[1] cmp $b->[1] } # sort map { [$_, lc(@{$_}[0].@{$_}[1])] } # transform: value, sortkey $relationship_type->holds_over_chain(); foreach my $holds_over_chain (@sorted_hocs) { print $output_file_handle "\nholds_over_chain: ", @{$holds_over_chain}[0], ' ', @{$holds_over_chain}[1]; } # # functional # print $output_file_handle "\nfunctional: true" if ($relationship_type->functional() == 1); # # inverse_functional # print $output_file_handle "\ninverse_functional: true" if ($relationship_type->inverse_functional() == 1); # # created_by # print $output_file_handle "\ncreated_by: ", $relationship_type->created_by() if (defined $relationship_type->created_by()); # # creation_date # print $output_file_handle "\ncreation_date: ", $relationship_type->creation_date() if (defined $relationship_type->creation_date()); # # modified_by # print $output_file_handle "\nmodified_by: ", $relationship_type->modified_by() if (defined $relationship_type->modified_by()); # # modification_date # print $output_file_handle "\nmodification_date: ", $relationship_type->modification_date() if (defined $relationship_type->modification_date()); # # is_obsolete # print $output_file_handle "\nis_obsolete: true" if ($relationship_type->is_obsolete()); # # replaced_by # foreach my $replaced_by ($relationship_type->replaced_by()->get_set()) { print $output_file_handle "\nreplaced_by: ", $replaced_by; } # # consider # foreach my $consider ($relationship_type->consider()->get_set()) { print $output_file_handle "\nconsider: ", $consider; } # # is_metadata_tag # print $output_file_handle "\nis_metadata_tag: true" if ($relationship_type->is_metadata_tag() == 1); # # is_class_level # print $output_file_handle "\nis_class_level: true" if ($relationship_type->is_class_level() == 1); # # the end... # print $output_file_handle "\n"; } } =head2 export2rdf See - OBO::Core::Ontology::export() =cut sub export2rdf { my ($self, $output_file_handle, $error_file_handle, $base, $namespace, $rdf_tc, $skip) = @_; if ($base && $base !~ /^http/) { croak "RDF export: you must provide a valid URL, e.g. export('rdf', \*STDOUT, \*STDERR, 'http://www.cellcycleontology.org/ontology/rdf/')"; } elsif (!defined $namespace){ croak "RDF export: you must provide a valid namespace (e.g. 'SSB')"; } my $default_URL = $base; my $NS = uc ($namespace); my $ns = lc ($namespace); # # Preamble: namespaces # print $output_file_handle "\n"; print $output_file_handle "\n"; ####################################################################### # # Terms # ####################################################################### my @all_terms = @{$self->get_terms_sorted_by_id()}; foreach my $term (@all_terms) { my $term_id = $term->id(); # vlmir - the 3 lines below make the export compatible with BFO, CCO and GenXO $term_id =~ tr/[_\-]//; # vlmir - trimming (needed for CCO and GenXO, does not harm anyway) $term_id =~ /\A(\w+):/xms; # vlmir $1 ? my $rdf_subnamespace = $1:next; # vlmir - bad ID $term_id =~ tr/:/_/; print $output_file_handle "\t<",$ns,":".$rdf_subnamespace." rdf:about=\"#".$term_id."\">\n"; # # is_anonymous # print $output_file_handle "\t\t<",$ns,":is_anonymous>true\n" if ($term->is_anonymous()); # # name # my $term_name = $term->name(); my $term_name_to_print = (defined $term_name)?$term_name:'no_name'; print $output_file_handle "\t\t".&__char_hex_http($term_name_to_print)."\n"; # # alt_id # foreach my $alt_id ($term->alt_id()->get_set()) { print $output_file_handle "\t\t<",$ns,":hasAlternativeId>", $alt_id, "\n"; } # # builtin # print $output_file_handle "\t\t<",$ns,":builtin>true\n" if ($term->builtin() == 1); # # property_value # my @property_values = sort {$a->id() cmp $b->id()} $term->property_value()->get_set(); foreach my $value (@property_values) { if (defined $value->head()->instance_of()) { print $output_file_handle "\t\t<",$ns,":property_value>\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t<",$ns,":property>", $value->type(),'\n"; print $output_file_handle "\t\t\t\t<",$ns,":value rdf:type=\"",$value->head()->instance_of()->id(),"\">", $value->head()->id(),'\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t"; } else { print $output_file_handle "\t\t<",$ns,":property_value>\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t<",$ns,":property>", $value->type(),'\n"; print $output_file_handle "\t\t\t\t<",$ns,":value>", $value->head()->id(),'\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t"; } } # # def # if (defined $term->def()->text()) { print $output_file_handle "\t\t<",$ns,":Definition>\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t<",$ns,":def>", &__char_hex_http($term->def()->text()), "\n"; for my $ref ($term->def()->dbxref_set()->get_set()) { print $output_file_handle "\t\t\t\t<",$ns,":DbXref>\n"; print $output_file_handle "\t\t\t\t\t\n"; print $output_file_handle "\t\t\t\t\t\t<",$ns,":acc>", $ref->acc(),"\n"; print $output_file_handle "\t\t\t\t\t\t<",$ns,":dbname>", $ref->db(),"\n"; print $output_file_handle "\t\t\t\t\t\n"; print $output_file_handle "\t\t\t\t\n"; } print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\n"; } # # comment # if(defined $term->comment()){ print $output_file_handle "\t\t".&__char_hex_http($term->comment())."\n"; } # # subset # foreach my $sset_name ($term->subset()) { if ($self->subset_def_map()->contains_key($sset_name)) { print $output_file_handle "\t\t<",$ns,":subset>",$sset_name,"\n"; } else { print $error_file_handle "\nThe term ", $term->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n"; } } # # synonym # foreach my $synonym ($term->synonym_set()) { print $output_file_handle "\t\t<",$ns,":synonym>\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t<",$ns,":syn>", &__char_hex_http($synonym->def()->text()), "\n"; print $output_file_handle "\t\t\t\t<",$ns,":scope>", $synonym->scope(),"\n"; for my $ref ($synonym->def()->dbxref_set()->get_set()) { print $output_file_handle "\t\t\t\t<",$ns,":DbXref>\n"; print $output_file_handle "\t\t\t\t\t\n"; print $output_file_handle "\t\t\t\t\t\t<",$ns,":acc>", $ref->acc(),"\n"; print $output_file_handle "\t\t\t\t\t\t<",$ns,":dbname>", $ref->db(),"\n"; print $output_file_handle "\t\t\t\t\t\n"; print $output_file_handle "\t\t\t\t\n"; } print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\n"; } # # xref # my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $term->xref_set_as_string()); foreach my $xref (@sorted_xrefs) { print $output_file_handle "\t\t<",$ns,":xref>\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t<",$ns,":acc>", $xref->acc(),'\n"; print $output_file_handle "\t\t\t\t<",$ns,":dbname>", $xref->db(),'\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\n"; } # # is_a # my $rt = $self->get_relationship_type_by_id('is_a'); if (defined $rt) { print $output_file_handle "\t\t<",$ns,":is_a rdf:resource=\"#", $term_id, "\"/>\n" if ($rdf_tc); # workaround for the rdf_tc!!! my %saw_is_a; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) { my $head_id = $head->id(); $head_id =~ tr/:/_/; print $output_file_handle "\t\t<",$ns,":is_a rdf:resource=\"#", $head_id, "\"/>\n"; } } # # intersection_of (at least 2 entries) # foreach my $tr ($term->intersection_of()) { # TODO Improve this export my $tr_head = $tr->head(); my $tr_type = $tr->type(); my $tr_head_id = $tr_head->id(); $tr_head_id =~ tr/:/_/; my $intersection_of_txt = ''; $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil'); $intersection_of_txt .= $tr_head_id; print $output_file_handle "\t\t<",$ns,":intersection_of rdf:resource=\"#", $intersection_of_txt, "\"/>\n"; } # # union_of (at least 2 entries) # foreach my $union_of_term_id ($term->union_of()) { $union_of_term_id =~ tr/:/_/; print $output_file_handle "\t\t<",$ns,":union_of rdf:resource=\"#", $union_of_term_id, "\"/>\n"; } # # disjoint_from # foreach my $disjoint_term_id ($term->disjoint_from()) { $disjoint_term_id =~ tr/:/_/; print $output_file_handle "\t\t<",$ns,":disjoint_from rdf:resource=\"#", $disjoint_term_id, "\"/>\n"; } # # relationship # foreach my $rt ( @{$self->get_relationship_types_sorted_by_id()} ) { my $rt_name = $rt->name(); if ($rt_name && $rt_name ne 'is_a') { # is_a is printed above my $rt_name_clean = __get_name_without_whitespaces($rt_name); 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!!! my %saw_rel; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) { my $head_id = $head->id(); $head_id =~ tr/:/_/; print $output_file_handle "\t\t<",$ns,":", $rt_name_clean," rdf:resource=\"#", $head_id, "\"/>\n"; } } } # # created_by # print $output_file_handle "\t\t<",$ns,':created_by>', $term->created_by(), '\n" if (defined $term->created_by()); # # creation_date # print $output_file_handle "\t\t<",$ns,':creation_date>', $term->creation_date(), '\n" if (defined $term->creation_date()); # # modified_by # print $output_file_handle "\t\t<",$ns,':modified_by>', $term->modified_by(), '\n" if (defined $term->modified_by()); # # modification_date # print $output_file_handle "\t\t<",$ns,':modification_date>', $term->modification_date(), '\n" if (defined $term->modification_date()); # # is_obsolete # print $output_file_handle "\t\t<",$ns,':is_obsolete>true\n" if ($term->is_obsolete() == 1); # # replaced_by # foreach my $replaced_by ($term->replaced_by()->get_set()) { print $output_file_handle "\t\t<",$ns,':replaced_by>', $replaced_by, '\n"; } # # consider # foreach my $consider ($term->consider()->get_set()) { print $output_file_handle "\t\t<",$ns,':consider>', $consider, '\n"; } # # end of term # print $output_file_handle "\t\n"; } ####################################################################### # # instances # ####################################################################### my @all_instances = @{$self->get_instances_sorted_by_id()}; foreach my $instance (@all_instances) { # TODO export instances } ####################################################################### # # relationship types # ####################################################################### unless ($skip) { # for integration processes and using biometarel for example. my @all_relationship_types = values(%{$self->{RELATIONSHIP_TYPES}}); foreach my $relationship_type (@all_relationship_types) { my $relationship_type_id = $relationship_type->id(); $relationship_type_id =~ tr/:/_/; print $output_file_handle "\t<",$ns,":rel_type rdf:about=\"#".$relationship_type_id."\">\n"; # # is_anonymous # print $output_file_handle "\t\t<",$ns,':is_anonymous>true\n" if ($relationship_type->is_anonymous()); # # namespace # foreach my $nspace ($relationship_type->namespace()) { print $output_file_handle "\t\t<",$ns,':namespace>', $nspace, '\n"; } # # alt_id # foreach my $alt_id ($relationship_type->alt_id()->get_set()) { print $output_file_handle "\t\t<",$ns,':alt_id>', $alt_id, '\n"; } # # builtin # print $output_file_handle "\t\t<",$ns,':builtin>true\n" if ($relationship_type->builtin() == 1); # # name # if (defined $relationship_type->name()) { print $output_file_handle "\t\t".&__char_hex_http($relationship_type->name())."\n"; } else { print $output_file_handle "\t\n"; # close the relationship type tag! (skipping the rest of the data, contact those guys) next; } # # def # if (defined $relationship_type->def()->text()) { print $output_file_handle "\t\t<",$ns,":Definition>\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t<",$ns,':def>', &__char_hex_http($relationship_type->def()->text()), "\n"; for my $ref ($relationship_type->def()->dbxref_set()->get_set()) { print $output_file_handle "\t\t\t\t<",$ns,":DbXref>\n"; print $output_file_handle "\t\t\t\t\t\n"; print $output_file_handle "\t\t\t\t\t\t<",$ns,':acc>', $ref->acc(),'\n"; print $output_file_handle "\t\t\t\t\t\t<",$ns,':dbname>', $ref->db(),'\n"; print $output_file_handle "\t\t\t\t\t\n"; print $output_file_handle "\t\t\t\t\n"; } print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\n"; } # # comment # if(defined $relationship_type->comment()){ print $output_file_handle "\t\t".&__char_hex_http($relationship_type->comment())."\n"; } # # subset # foreach my $sset_name ($relationship_type->subset()) { if ($self->subset_def_map()->contains_key($sset_name)) { print $output_file_handle "\t\t<",$ns,":subset>",$sset_name,"\n"; } else { 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"; } } # # synonym # foreach my $synonym ($relationship_type->synonym_set()) { print $output_file_handle "\t\t<",$ns,":synonym>\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t<",$ns,':syn>', &__char_hex_http($synonym->def()->text()), "\n"; print $output_file_handle "\t\t\t\t<",$ns,':scope>', $synonym->scope(),'\n"; for my $ref ($synonym->def()->dbxref_set()->get_set()) { print $output_file_handle "\t\t\t\t<",$ns,":DbXref>\n"; print $output_file_handle "\t\t\t\t\t\n"; print $output_file_handle "\t\t\t\t\t\t<",$ns,':acc>', $ref->acc(),'\n"; print $output_file_handle "\t\t\t\t\t\t<",$ns,':dbname>', $ref->db(),'\n"; print $output_file_handle "\t\t\t\t\t\n"; print $output_file_handle "\t\t\t\t\n"; } print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\n"; } # # xref # my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $relationship_type->xref_set_as_string()); foreach my $xref (@sorted_xrefs) { print $output_file_handle "\t\t<",$ns,":xref>\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t<",$ns,':acc>', $xref->acc(),'\n"; print $output_file_handle "\t\t\t\t<",$ns,':dbname>', $xref->db(),'\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\n"; } # # domain # foreach my $domain ($relationship_type->domain()->get_set()) { print $output_file_handle "\t\t<",$ns,':domain>', $domain, '\n"; } # # range # foreach my $range ($relationship_type->range()->get_set()) { print $output_file_handle "\t\t<",$ns,':range>', $range, '\n"; } print $output_file_handle "\t\t<",$ns,':is_anti_symmetric>true\n" if ($relationship_type->is_anti_symmetric() == 1); print $output_file_handle "\t\t<",$ns,':is_cyclic>true\n" if ($relationship_type->is_cyclic() == 1); print $output_file_handle "\t\t<",$ns,':is_reflexive>true\n" if ($relationship_type->is_reflexive() == 1); print $output_file_handle "\t\t<",$ns,':is_symmetric>true\n" if ($relationship_type->is_symmetric() == 1); print $output_file_handle "\t\t<",$ns,':is_transitive>true\n" if ($relationship_type->is_transitive() == 1); # # is_a # my $rt = $self->get_relationship_type_by_id('is_a'); if (defined $rt) { my @heads = @{$self->get_head_by_relationship_type($relationship_type, $rt)}; foreach my $head (@heads) { my $head_id = $head->id(); $head_id =~ tr/:/_/; print $output_file_handle "\t\t<",$ns,":is_a rdf:resource=\"#", $head_id, "\"/>\n"; } } # # intersection_of (at least 2 entries) # foreach my $tr ($relationship_type->intersection_of()) { # TODO Improve this export my $tr_head = $tr->head(); my $tr_type = $tr->type(); my $tr_head_id = $tr_head->id(); $tr_head_id =~ tr/:/_/; my $intersection_of_txt = ""; $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil'); $intersection_of_txt .= $tr_head_id; print $output_file_handle "\t\t<",$ns,":intersection_of rdf:resource=\"#", $intersection_of_txt, "\"/>\n"; } # # union_of (at least 2 entries) # foreach my $union_of_rt_id ($relationship_type->union_of()) { $union_of_rt_id =~ tr/:/_/; print $output_file_handle "\t\t<",$ns,":union_of rdf:resource=\"#", $union_of_rt_id, "\"/>\n"; } # # disjoint_from # foreach my $df ($relationship_type->disjoint_from()) { print $output_file_handle "\t\t<",$ns,":disjoint_from rdf:resource=\"#", $df, "\"/>\n"; } # # inverse_of # my $ir = $relationship_type->inverse_of(); if (defined $ir) { print $output_file_handle "\t\t<",$ns,":inverse_of rdf:resource=\"#", $ir->id(), "\"/>\n"; } # # transitive_over # foreach my $transitive_over ($relationship_type->transitive_over()->get_set()) { print $output_file_handle "\t\t<",$ns,':transitive_over>', $transitive_over, '\n"; } # # holds_over_chain # foreach my $holds_over_chain ($relationship_type->holds_over_chain()) { print $output_file_handle "\t\t<",$ns,":holds_over_chain>\n"; print $output_file_handle "\t\t\t<",$ns,':r1>', @{$holds_over_chain}[0], '\n"; print $output_file_handle "\t\t\t<",$ns,':r2>', @{$holds_over_chain}[1], '\n"; print $output_file_handle "\t\t<",$ns,":/holds_over_chain>\n"; } # # functional # print $output_file_handle "\t\t<",$ns,':functional>true\n" if ($relationship_type->functional() == 1); # # inverse_functional # print $output_file_handle "\t\t<",$ns,':inverse_functional>true\n" if ($relationship_type->inverse_functional() == 1); # # created_by # print $output_file_handle "\t\t<",$ns,':created_by>', $relationship_type->created_by(), '\n" if (defined $relationship_type->created_by()); # # creation_date # print $output_file_handle "\t\t<",$ns,':creation_date>', $relationship_type->creation_date(), '\n" if (defined $relationship_type->creation_date()); # # modified_by # print $output_file_handle "\t\t<",$ns,':modified_by>', $relationship_type->modified_by(), '\n" if (defined $relationship_type->modified_by()); # # modification_date # print $output_file_handle "\t\t<",$ns,':modification_date>', $relationship_type->modification_date(), "\n" if (defined $relationship_type->modification_date()); # # is_obsolete # print $output_file_handle "\t\t<",$ns,':is_obsolete>true\n" if ($relationship_type->is_obsolete() == 1); # # replaced_by # foreach my $replaced_by ($relationship_type->replaced_by()->get_set()) { print $output_file_handle "\t\t<",$ns,':replaced_by>', $replaced_by, '\n"; } # # consider # foreach my $consider ($relationship_type->consider()->get_set()) { print $output_file_handle "\t\t<",$ns,':consider>', $consider, '\n"; } # # is_metadata_tag # print $output_file_handle "\t\t<",$ns,':is_metadata_tag>true\n" if ($relationship_type->is_metadata_tag() == 1); # # is_class_level # print $output_file_handle "\t\t<",$ns,':is_class_level>true\n" if ($relationship_type->is_class_level() == 1); # # end of relationship type # print $output_file_handle "\t\n"; } } # # EOF: # print $output_file_handle "\n\n"; print $output_file_handle ""; } =head2 export2owl See - OBO::Core::Ontology::export() =cut sub export2owl { my ($self, $output_file_handle, $error_file_handle, $oboContentUrl, $oboInOwlUrl) = @_; if ($oboContentUrl !~ /^http/) { croak "OWL export: you must provide a valid URL, e.g. export('owl', \*STDOUT, \*STDERR, 'http://www.cellcycleontology.org/ontology/owl/')"; } if ($oboInOwlUrl !~ /^http/) { ( $oboInOwlUrl = $oboContentUrl ) =~ s{/\w+/owl/\z}{/formats/oboInOwl#}xms; carp "Using a default URI for OboInOwl '$oboInOwlUrl' "; } # # preambule # print $output_file_handle "\n"; print $output_file_handle "id() || $self->get_terms_idspace(); print $output_file_handle "\txml:base=\"".$oboContentUrl.$ontology_id_space."\"\n"; #print $output_file_handle "\txmlns:p1=\"http://protege.stanford.edu/plugins/owl/dc/protege-dc.owl#\"\n"; #print $output_file_handle "\txmlns:dcterms=\"http://purl.org/dc/terms/\"\n"; #print $output_file_handle "\txmlns:xsp=\"http://www.owl-ontologies.com/2005/08/07/xsp.owl#\"\n"; #print $output_file_handle "\txmlns:dc=\"http://purl.org/dc/elements/1.1/\"\n"; print $output_file_handle ">\n"; # # meta-data: oboInOwl elements # foreach my $ap ('hasURI', 'hasAlternativeId', 'hasDate', 'hasVersion', 'hasDbXref', 'hasDefaultNamespace', 'hasNamespace', 'hasDefinition', 'hasExactSynonym', 'hasNarrowSynonym', 'hasBroadSynonym', 'hasRelatedSynonym', 'hasSynonymType', 'hasSubset', 'inSubset', 'savedBy', 'replacedBy', 'consider') { print $output_file_handle "\n"; } foreach my $c ('DbXref', 'Definition', 'Subset', 'Synonym', 'SynonymType', 'ObsoleteClass') { print $output_file_handle "\n"; } print $output_file_handle "\n"; print $output_file_handle "\n"; # # header: http://oe0.spreadsheets.google.com/ccc?id=o06770842196506107736.4732937099693365844.03735622766900057712.3276521997699206495# # print $output_file_handle "\n"; foreach my $import_obo ($self->imports()->get_set()) { # As Ontology.pm is independant of the format (OBO, OWL) it will import the ID of the ontology (my $import_owl = $import_obo) =~ s/\.obo/\.owl/; print $output_file_handle "\t\n"; } # format-version is not treated print $output_file_handle "\t", $self->date(), "\n" if ($self->date()); print $output_file_handle "\t", $self->data_version(), "\n" if ($self->data_version()); print $output_file_handle '\t\t', $self->id(), "\n" if ($self->id()); print $output_file_handle "\t", $self->saved_by(), "\n" if ($self->saved_by()); #print $output_file_handle "\tautogenerated-by: ", $0, "\n"; print $output_file_handle "\t", $self->default_namespace(), "\n" if ($self->default_namespace()); foreach my $remark ($self->remarks()->get_set()) { print $output_file_handle "\t", $remark, "\n"; } # treat-xrefs-as-equivalent foreach my $id_space_xref_eq (sort {lc($a) cmp lc($b)} $self->treat_xrefs_as_equivalent()->get_set()) { print $output_file_handle '\t\t', $id_space_xref_eq, "\n"; } # subsetdef foreach my $subsetdef (sort {lc($a->name()) cmp lc($b->name())} $self->subset_def_map()->values()) { print $output_file_handle "\t\n"; print $output_file_handle "\t\tname(), "\">\n"; print $output_file_handle "\t\t\t", $subsetdef->description(), "\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\n"; } # synonyntypedef foreach my $st ($self->synonym_type_def_set()->get_set()) { print $output_file_handle "\t\n"; print $output_file_handle "\t\tname(), "\">\n"; print $output_file_handle "\t\t\t", $st->description(), "\n"; my $scope = $st->scope(); print $output_file_handle "\t\t\t", $scope, "\n" if (defined $scope); print $output_file_handle "\t\t\n"; print $output_file_handle "\t\n"; } # idspace my $ids = $self->idspaces()->get_set(); my $local_idspace = undef; if (defined $ids) { $local_idspace = $ids->local_idspace(); if ($local_idspace) { print $output_file_handle "\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", $local_idspace, "\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", $self->idspace()->uri(), "\n"; print $output_file_handle "\t\t\n"; my $desc = $ids->description(); print $output_file_handle "\t\t", $desc, "\n"; print $output_file_handle "\t\n"; } } # Ontology end tag print $output_file_handle "\n\n"; ####################################################################### # # term # ####################################################################### my @all_terms = @{$self->get_terms_sorted_by_id()}; # visit the terms foreach my $term (@all_terms){ # for the URLs my $term_id = $term->id(); $local_idspace = $local_idspace || (split(':', $term_id))[0]; # the idspace or the space from the term itself. e.g. APO # # Class name # print $output_file_handle "\n"; # # label name = class name # print $output_file_handle "\t", &__char_hex_http($term->name()), "\n" if ($term->name()); # # comment # print $output_file_handle "\t", $term->comment(), "\n" if ($term->comment()); # # subset # foreach my $sset_name ($term->subset()) { if ($self->subset_def_map()->contains_key($sset_name)) { print $output_file_handle "\t\n"; } else { print $error_file_handle "\nThe term ", $term->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n"; } } # # Def # if (defined $term->def()->text()) { print $output_file_handle "\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", &__char_hex_http($term->def()->text()), "\n"; print_hasDbXref_for_owl($output_file_handle, $term->def()->dbxref_set(), $oboContentUrl, 3); print $output_file_handle "\t\t\n"; print $output_file_handle "\t\n"; } # # synonym: # foreach my $synonym ($term->synonym_set()) { my $st = $synonym->scope(); my $synonym_type; if ($st eq 'EXACT') { $synonym_type = 'hasExactSynonym'; } elsif ($st eq 'BROAD') { $synonym_type = 'hasBroadSynonym'; } elsif ($st eq 'NARROW') { $synonym_type = 'hasNarrowSynonym'; } elsif ($st eq 'RELATED') { $synonym_type = 'hasRelatedSynonym'; } else { # TODO Consider the synonym types defined in the header: 'synonymtypedef' tag croak 'A non-valid synonym type has been found ($synonym). Valid types: EXACT, BROAD, NARROW, RELATED'; } print $output_file_handle "\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", $synonym->def()->text(), "\n"; print_hasDbXref_for_owl($output_file_handle, $synonym->def()->dbxref_set(), $oboContentUrl, 3); print $output_file_handle "\t\t\n"; print $output_file_handle "\t\n"; } # # namespace # foreach my $ns ($term->namespace()) { print $output_file_handle "\t", $ns, "\n"; } # # alt_id: # foreach my $alt_id ($term->alt_id()->get_set()) { print $output_file_handle "\t", $alt_id, "\n"; } # # xref's # print_hasDbXref_for_owl($output_file_handle, $term->xref_set(), $oboContentUrl, 1); # # is_a: # # my @disjoint_term = (); # for collecting the disjoint terms of the running term my $rt = $self->get_relationship_type_by_id('is_a'); if (defined $rt) { my %saw_is_a; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) { print $output_file_handle "\tid()), "\"/>\n"; # head->name() not used # # # # Gathering for the Disjointness (see below, after the bucle) # # # # my $child_rels = $graph->get_child_relationships($rel->object_acc); # # foreach my $r (@{$child_rels}){ # # if ($r->scope eq 'is_a') { # Only consider the children playing a role in the is_a realtionship # # my $already_in_array = grep /$r->subject_acc/, @disjoint_term; # # push @disjoint_term, $r->subject_acc if (!$already_in_array && $r->subject_acc ne $rel->subject_acc()); # # } # # } } # # # # Disjointness (array filled up while treating the is_a relation) # # # # foreach my $disjoint (@disjoint_term){ # # $disjoint =~ tr/:/_/; # # print $output_file_handle "\t\n"; # # } } # # intersection_of # my @intersection_of = $term->intersection_of(); if (@intersection_of) { print $output_file_handle "\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t\n"; foreach my $tr (@intersection_of) { # TODO Improve the parsing of the 'interection_of' elements my @inter = split(/\s+/, $tr); # TODO Check the idspace of the terms in the set 'intersection_of' and optimize the code: only one call to $self->idspace()->local_idspace() my $idspace = ($tr =~ /([A-Z]+):/)?$1:$local_idspace; if (scalar @inter == 1) { my $idspace = ($tr =~ /([A-Z]+):/)?$1:$local_idspace; print $output_file_handle "\t\t\t\n"; } elsif (scalar @inter == 2) { # restriction print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\n"; } else { croak "Parsing error: 'intersection_of' tag has an unknown argument"; } } print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\n"; } # # union_of # my @union_of = $term->union_of(); if (@union_of) { print $output_file_handle "\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t\n"; foreach my $tr (@union_of) { # TODO Check the idspace of the terms in the set 'union_of' my $idspace = ($tr =~ /([A-Z]+):/)?$1:$local_idspace; print $output_file_handle "\t\t\t\n"; } print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\n"; } # # disjoint_from: # foreach my $disjoint_term_id ($term->disjoint_from()) { print $output_file_handle "\t\n"; } # # relationships: # foreach $rt ( @{$self->get_relationship_types_sorted_by_id()} ) { if ($rt->id() ne 'is_a') { # is_a is printed above my %saw_rel; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) { print $output_file_handle "\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\tid(), "\"/>\n"; print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\tid()), "\"/>\n"; # head->name() not used print $output_file_handle "\t\t\n"; print $output_file_handle "\t\n"; } } } # # obsolete # print $output_file_handle "\t\n" if ($term->is_obsolete()); # # builtin: # #### Not used in OWL.#### # # replaced_by # foreach my $replaced_by ($term->replaced_by()->get_set()) { print $output_file_handle "\t\n"; } # # consider # foreach my $consider ($term->consider()->get_set()) { print $output_file_handle "\t\n"; } # # End of the term # print $output_file_handle "\n\n"; } # # relationship types: properties # # TODO # print $output_file_handle "\n"; # print $output_file_handle "\tpart of\n"; # print $output_file_handle "\t", $self->default_namespace(), "\n" if ($self->default_namespace()); # print $output_file_handle "\n"; foreach my $relationship_type ( @{$self->get_relationship_types_sorted_by_id()} ) { my $relationship_type_id = $relationship_type->id(); next if ($relationship_type_id eq 'is_a'); # rdfs:subClassOf covers this property (relationship) # # Object property # print $output_file_handle "\n"; # # name: # my $relationship_type_name = $relationship_type->name(); if (defined $relationship_type_name) { print $output_file_handle "\t", $relationship_type_name, "\n"; } # # comment: # print $output_file_handle "\t", $relationship_type->comment(), "\n" if ($relationship_type->comment()); # # Def: # if (defined $relationship_type->def()->text()) { print $output_file_handle "\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", &__char_hex_http($relationship_type->def()->text()), "\n"; print_hasDbXref_for_owl($output_file_handle, $relationship_type->def()->dbxref_set(), $oboContentUrl, 3); print $output_file_handle "\t\t\n"; print $output_file_handle "\t\n"; } # # Synonym: # foreach my $synonym ($relationship_type->synonym_set()) { my $st = $synonym->scope(); my $synonym_type; if ($st eq 'EXACT') { $synonym_type = 'hasExactSynonym'; } elsif ($st eq 'BROAD') { $synonym_type = 'hasBroadSynonym'; } elsif ($st eq 'NARROW') { $synonym_type = 'hasNarrowSynonym'; } elsif ($st eq 'RELATED') { $synonym_type = 'hasRelatedSynonym'; } else { # TODO Consider the synonym types defined in the header: 'synonymtypedef' tag croak 'A non-valid synonym type has been found ($synonym). Valid types: EXACT, BROAD, NARROW, RELATED'; } print $output_file_handle "\t\n"; print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", $synonym->def()->text(), "\n"; print_hasDbXref_for_owl($output_file_handle, $synonym->def()->dbxref_set(), $oboContentUrl, 3); print $output_file_handle "\t\t\n"; print $output_file_handle "\t\n"; } # # namespace: TODO implement namespace in relationship # foreach my $ns ($relationship_type->namespace()) { print $output_file_handle "\t", $ns, "\n"; } # # alt_id: TODO implement alt_id in relationship # foreach my $alt_id ($relationship_type->alt_id()->get_set()) { print $output_file_handle "\t", $alt_id, "\n"; } # # is_a: # my $rt = $self->get_relationship_type_by_id('is_a'); if (defined $rt) { my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($relationship_type, $rt)}); foreach my $head (@sorted_heads) { print $output_file_handle "\tid()), "\"/>\n"; # head->name() not used } } # # Properties: # print $output_file_handle "\t\n" if ($relationship_type->is_transitive()); print $output_file_handle "\t\n" if ($relationship_type->is_symmetric()); # No cases so far print $output_file_handle "\t\n" if ($relationship_type->is_metadata_tag()); print $output_file_handle "\t\n" if ($relationship_type->is_class_level()); #print $output_file_handle "\ttrue\n" if ($relationship_type->is_reflexive()); #print $output_file_handle "\ttrue\n" if ($relationship_type->is_anti_symmetric()); # anti-symmetric <> not symmetric # # xref's # print_hasDbXref_for_owl($output_file_handle, $relationship_type->xref_set(), $oboContentUrl, 1); ## There is no way to code these rel's in OBO ##print $output_file_handle "\t\n" if (${$relationship{$_}}{"TODO"}); ##print $output_file_handle "\t\n" if (${$relationship{$_}}{"TODO"}); ##print $output_file_handle "\t\n" if (${$relationship{$_}}{"TODO"}); print $output_file_handle "\n\n"; # # replaced_by # foreach my $replaced_by ($relationship_type->replaced_by()->get_set()) { print $output_file_handle "\t\n"; } # # consider # foreach my $consider ($relationship_type->consider()->get_set()) { print $output_file_handle "\t\n"; } } # # # # # Datatype annotation properties: todo: AnnotationProperty or not? # # # # # autoGeneratedBy # #print $output_file_handle "\n"; # #print $output_file_handle "\t\n"; # #print $output_file_handle "\t\n"; # #print $output_file_handle "\t", "The program that generated this ontology.", "\n"; # #print $output_file_handle "\n\n"; # # # is_anti_symmetric # print $output_file_handle "\n"; # print $output_file_handle "\t\n"; # print $output_file_handle "\n\n"; # # # is_reflexive # print $output_file_handle "\n"; # print $output_file_handle "\t\n"; # print $output_file_handle "\n\n"; # # EOF: # print $output_file_handle "\n\n"; print $output_file_handle ""; } =head2 export2xml See - OBO::Core::Ontology::export() =cut sub export2xml { my ($self, $output_file_handle, $error_file_handle) = @_; # terms my @all_terms = @{$self->get_terms_sorted_by_id()}; # terms idspace my $NS = lc ($self->get_terms_idspace()); # preambule: OBO header tags print $output_file_handle "\n\n"; print $output_file_handle "<".$NS.">\n"; print $output_file_handle "\t
\n"; print $output_file_handle "\t\t1.4\n"; my $data_version = $self->data_version(); print $output_file_handle "\t\t", $data_version, "\n" if ($data_version); my $ontology_id_space = $self->id(); print $output_file_handle '\t\t', $ontology_id_space, "\n" if ($ontology_id_space); chomp(my $date = (defined $self->date())?$self->date():__date()); #`date '+%d:%m:%Y %H:%M'`); print $output_file_handle "\t\t", $date, "\n"; my $saved_by = $self->saved_by(); print $output_file_handle "\t\t", $saved_by, "\n" if ($saved_by); print $output_file_handle "\t\tONTO-PERL ", $VERSION, "\n"; # import foreach my $import ($self->imports()->get_set()) { print $output_file_handle "\t\t", $import, "\n"; } # subsetdef foreach my $subsetdef (sort {lc($a->name()) cmp lc($b->name())} $self->subset_def_map()->values()) { print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", $subsetdef->name(), "\n"; print $output_file_handle "\t\t\t", $subsetdef->description(), "\n"; print $output_file_handle "\t\t\n"; } # synonyntypedef foreach my $st ($self->synonym_type_def_set()->get_set()) { print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", $st->name(), "\n"; print $output_file_handle "\t\t\t", $st->scope(), "\n"; print $output_file_handle "\t\t\t", $st->description(), "\n"; print $output_file_handle "\t\t\n"; } # idspace's foreach my $idspace ($self->idspaces()->get_set()) { print $output_file_handle "\t\t", $idspace->as_string(), "\n"; } # default_namespace my $dns = $self->default_namespace(); print $output_file_handle "\t\t", $dns, "\n" if (defined $dns); # remark's foreach my $remark ($self->remarks()->get_set()) { print $output_file_handle "\t\t", $remark, "\n"; } # treat-xrefs-as-equivalent foreach my $id_space_xref_eq (sort {lc($a) cmp lc($b)} $self->treat_xrefs_as_equivalent()->get_set()) { print $output_file_handle '\t\t', $id_space_xref_eq, "\n"; } print $output_file_handle "\t
\n\n"; ####################################################################### # # terms # ####################################################################### foreach my $term (@all_terms) { # # [Term] # print $output_file_handle "\t\n"; # # id # print $output_file_handle "\t\t", $term->id(), "\n"; # # is_anonymous # print $output_file_handle "\t\ttrue\n" if ($term->is_anonymous()); # # name # print $output_file_handle "\t\t", &__char_hex_http($term->name()), "\n" if (defined $term->name()); # # namespace # foreach my $ns ($term->namespace()) { print $output_file_handle "\t\t", $ns, "\n"; } # # alt_id # foreach my $alt_id ($term->alt_id()->get_set()) { print $output_file_handle "\t\t", $alt_id, "\n"; } # # builtin # print $output_file_handle "\t\ttrue\n" if ($term->builtin() == 1); # # property_value # my @property_values = sort {$a->id() cmp $b->id()} $term->property_value()->get_set(); foreach my $value (@property_values) { if (defined $value->head()->instance_of()) { print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", $value->type(),"\n"; print $output_file_handle "\t\t\thead()->instance_of()->id(),"\">", $value->head()->id(),"\n"; print $output_file_handle "\t\t"; } else { print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", $value->type(),"\n"; print $output_file_handle "\t\t\t", $value->head()->id(),"\n"; print $output_file_handle "\t\t"; } # TODO Finalise this implementation print $output_file_handle "\t\t\n"; } # # def # my $term_def = $term->def(); if (defined $term_def->text()) { print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", &__char_hex_http($term_def->text()), "\n"; for my $ref ($term_def->dbxref_set()->get_set()) { print $output_file_handle "\t\t\tname(), "\">\n"; print $output_file_handle "\t\t\t\t", $ref->acc(),"\n"; print $output_file_handle "\t\t\t\t", $ref->db(),"\n"; print $output_file_handle "\t\t\t\n"; } print $output_file_handle "\t\t\n"; } # # comment # my $comment = $term->comment(); print $output_file_handle "\t\t", &__char_hex_http($comment), "\n" if (defined $comment); # # subset # foreach my $sset_name ($term->subset()) { if ($self->subset_def_map()->contains_key($sset_name)) { print $output_file_handle "\t\t", $sset_name, "\n"; } else { print $error_file_handle "\nThe term ", $term->id(), " belongs to a non-defined subset ($sset_name).\nYou should add the missing subset definition.\n"; } } # # synonym: # foreach my $synonym ($term->synonym_set()) { print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", &__char_hex_http($synonym->def()->text()), "\n"; print $output_file_handle "\t\t\t", $synonym->scope(),"\n"; for my $ref ($synonym->def()->dbxref_set()->get_set()) { print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t", $ref->acc(),"\n"; print $output_file_handle "\t\t\t\t", $ref->db(),"\n"; print $output_file_handle "\t\t\t\n"; } print $output_file_handle "\t\t\n"; } # # xref # my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $term->xref_set_as_string()); foreach my $xref (@sorted_xrefs) { print $output_file_handle "\t\t", $xref->as_string(), "\n"; } # # is_a # my $rt = $self->get_relationship_type_by_id('is_a'); if (defined $rt) { my %saw_is_a; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) { my $head_name = $head->name(); my $head_name_to_print = (defined $head_name)?$head_name:"no_name"; print $output_file_handle "\t\tid()."\">".$head_name_to_print."\n"; } } # # intersection_of (at least 2 entries) # foreach my $tr ($term->intersection_of()) { # TODO Improve this export my $tr_head = $tr->head(); my $tr_type = $tr->type(); my $tr_head_id = $tr_head->id(); $tr_head_id =~ tr/:/_/; my $intersection_of_txt = ""; $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil'); $intersection_of_txt .= $tr_head_id; print $output_file_handle "\t\t", $intersection_of_txt, "\n"; } # # union_of (at least 2 entries) # foreach my $union_of_term_id ($term->union_of()) { $union_of_term_id =~ tr/:/_/; print $output_file_handle "\t\t", $union_of_term_id, "\n"; } # # disjoint_from: # foreach my $disjoint_term_id ($term->disjoint_from()) { print $output_file_handle "\t\t", $disjoint_term_id, "\n"; } # # relationship # foreach $rt ( @{$self->get_relationship_types_sorted_by_id()} ) { if ($rt->name() ne 'is_a') { # is_a is printed above my %saw_rel; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) { print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", $rt->name(), "\n"; print $output_file_handle "\t\t\tid(), "\">", $head->name(),"\n"; print $output_file_handle "\t\t\n"; } } } # # created_by # print $output_file_handle "\t\t", $term->created_by(), "\n" if (defined $term->created_by()); # # creation_date # print $output_file_handle "\t\t", $term->creation_date(), "\n" if (defined $term->creation_date()); # # modified_by # print $output_file_handle "\t\t", $term->modified_by(), "\n" if (defined $term->modified_by()); # # modification_date # print $output_file_handle "\t\t", $term->modification_date(), "\n" if (defined $term->modification_date()); # # is_obsolete # print $output_file_handle "\t\ttrue\n" if ($term->is_obsolete()); # # replaced_by # foreach my $replaced_by ($term->replaced_by()->get_set()) { print $output_file_handle "\t\t", $replaced_by, "\n"; } # # consider # foreach my $consider ($term->consider()->get_set()) { print $output_file_handle "\t\t", $consider, "\n"; } # # end # print $output_file_handle "\t\n\n"; } ####################################################################### # # instances # ####################################################################### my @all_instances = @{$self->get_instances_sorted_by_id()}; foreach my $instance (@all_instances) { # TODO export instances } ####################################################################### # # relationship types # ####################################################################### foreach my $relationship_type ( @{$self->get_relationship_types_sorted_by_id()} ) { print $output_file_handle "\t\n"; # # id # print $output_file_handle "\t\t", $relationship_type->id(), "\n"; # # is_anonymous # print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_anonymous()); # # name # my $relationship_type_name = $relationship_type->name(); if (defined $relationship_type_name) { print $output_file_handle "\t\t", &__char_hex_http($relationship_type_name), "\n"; } # # namespace # foreach my $nasp ($relationship_type->namespace()) { print $output_file_handle "\t\t", $nasp, "\n"; } # # alt_id # foreach my $alt_id ($relationship_type->alt_id()->get_set()) { print $output_file_handle "\t\t", $alt_id, "\n"; } # # builtin # print $output_file_handle "\t\ttrue\n" if ($relationship_type->builtin() == 1); # # def # my $relationship_type_def = $relationship_type->def(); if (defined $relationship_type_def->text()) { print $output_file_handle "\t\ttext()), "\">\n"; for my $ref ($relationship_type_def->dbxref_set()->get_set()) { print $output_file_handle "\t\t\tname(), "\">\n"; print $output_file_handle "\t\t\t\t", $ref->acc(),"\n"; print $output_file_handle "\t\t\t\t", $ref->db(),"\n"; print $output_file_handle "\t\t\t\n"; } print $output_file_handle "\t\t\n"; } # # comment # print $output_file_handle "\t\t", &__char_hex_http($relationship_type->comment()), "\n" if (defined $relationship_type->comment()); # # subset # foreach my $sset_name ($relationship_type->subset()) { if ($self->subset_def_map()->contains_key($sset_name)) { print $output_file_handle "\t\t",$sset_name,"\n"; } else { 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"; } } # # synonym # foreach my $rt_synonym ($relationship_type->synonym_set()) { print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", &__char_hex_http($rt_synonym->def()->text()), "\n"; print $output_file_handle "\t\t\t", $rt_synonym->scope(),"\n"; for my $ref ($rt_synonym->def()->dbxref_set()->get_set()) { print $output_file_handle "\t\t\t\n"; print $output_file_handle "\t\t\t\t", $ref->acc(),"\n"; print $output_file_handle "\t\t\t\t", $ref->db(),"\n"; print $output_file_handle "\t\t\t\n"; } print $output_file_handle "\t\t\n"; } # # xref # my @sorted_xrefs = __sort_by(sub {lc(shift)}, sub { OBO::Core::Dbxref::as_string(shift) }, $relationship_type->xref_set_as_string()); foreach my $xref (@sorted_xrefs) { print $output_file_handle "\t\t", $xref->as_string(), "\n"; } # # domain # foreach my $domain ($relationship_type->domain()->get_set()) { print $output_file_handle "\t\t", $domain, "\n"; } # # range # foreach my $range ($relationship_type->range()->get_set()) { print $output_file_handle "\t\t", $range, "\n"; } print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_anti_symmetric() == 1); print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_cyclic() == 1); print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_reflexive() == 1); print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_symmetric() == 1); print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_transitive() == 1); # # is_a: TODO missing function to retieve the rel types # my $rt = $self->get_relationship_type_by_id('is_a'); if (defined $rt) { my @heads = @{$self->get_head_by_relationship_type($relationship_type, $rt)}; foreach my $head (@heads) { print $output_file_handle "\t\t", $head->id(), "\n"; } } # # intersection_of (at least 2 entries) # foreach my $tr ($relationship_type->intersection_of()) { # TODO Improve this export my $tr_head = $tr->head(); my $tr_type = $tr->type(); my $tr_head_id = $tr_head->id(); $tr_head_id =~ tr/:/_/; my $intersection_of_txt = ""; $intersection_of_txt .= $tr_type.' ' if ($tr_type ne 'nil'); $intersection_of_txt .= $tr_head_id; print $output_file_handle "\t\t", $intersection_of_txt, "\n"; } # # union_of (at least 2 entries) # foreach my $union_of_rt_id ($relationship_type->union_of()) { $union_of_rt_id =~ tr/:/_/; print $output_file_handle "\t\t", $union_of_rt_id, "\n"; } # # disjoint_from # my $df = $relationship_type->disjoint_from(); if (defined $df) { print $output_file_handle "\t\t", $df, "\n"; } # # inverse_of # my $ir = $relationship_type->inverse_of(); if (defined $ir) { print $output_file_handle "\t\t", $ir->id(), "\n"; } # # transitive_over # foreach my $transitive_over ($relationship_type->transitive_over()->get_set()) { print $output_file_handle "\t\t", $transitive_over, "\n"; } # # holds_over_chain # foreach my $holds_over_chain ($relationship_type->holds_over_chain()) { print $output_file_handle "\t\t\n"; print $output_file_handle "\t\t\t", @{$holds_over_chain}[0], "\n"; print $output_file_handle "\t\t\t", @{$holds_over_chain}[1], "\n"; print $output_file_handle "\t\t\n"; } # # functional # print $output_file_handle "\t\ttrue\n" if ($relationship_type->functional() == 1); # # inverse_functional # print $output_file_handle "\t\ttrue\n" if ($relationship_type->inverse_functional() == 1); # # created_by # print $output_file_handle "\t\t", $relationship_type->created_by(), "\n" if (defined $relationship_type->created_by()); # # creation_date # print $output_file_handle "\t\t", $relationship_type->creation_date(), "\n" if (defined $relationship_type->creation_date()); # # is_obsolete # print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_obsolete()); # # replaced_by # foreach my $replaced_by ($relationship_type->replaced_by()->get_set()) { print $output_file_handle "\t\t", $replaced_by, "\n"; } # # consider # foreach my $consider ($relationship_type->consider()->get_set()) { print $output_file_handle "\t\t", $consider, "\n"; } # # is_metadata_tag # print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_metadata_tag() == 1); # # is_class_level # print $output_file_handle "\t\ttrue\n" if ($relationship_type->is_class_level() == 1); # # end typedef # print $output_file_handle "\t\n\n"; } print $output_file_handle "\n"; } =head2 export2dot See - OBO::Core::Ontology::export() =cut sub export2dot { my ($self, $output_file_handle, $error_file_handle) = @_; # # begin DOT format # print $output_file_handle 'digraph Ontology {'; print $output_file_handle "\n\tpage=\"11,17\";"; #print $output_file_handle "\n\tratio=auto;"; # terms my @all_terms = @{$self->get_terms_sorted_by_id()}; print $output_file_handle "\n\tedge [label=\"is a\"];"; foreach my $term (@all_terms) { my $term_id = $term->id(); # # is_a: term1 -> term2 # my $rt = $self->get_relationship_type_by_id('is_a'); if (defined $rt) { my %saw_is_a; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw_is_a{$_}++, @sorted_heads)) { if (!defined $term->name()) { warn 'Warning: The term with id: ', $term_id, ' has no name!' ; } elsif (!defined $head->name()) { warn 'Warning: The term with id: ', $head->id(), ' has no name!' ; } else { # TODO Write down the name() instead of the id() print $output_file_handle "\n\t", obo_id2owl_id($term_id), ' -> ', obo_id2owl_id($head->id()), ';'; } } } # # relationships: terms1 -> term2 # foreach $rt ( @{$self->get_relationship_types_sorted_by_id()} ) { if ($rt->name() ne 'is_a') { # is_a is printed above my @heads = @{$self->get_head_by_relationship_type($term, $rt)}; print $output_file_handle "\n\tedge [label=\"", $rt->name(), "\"];" if (@heads); my %saw_rel; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @heads); foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) { if (!defined $term->name()) { warn 'Warning: The term with id: ', $term_id, ' has no name!' ; } elsif (!defined $head->name()) { warn 'Warning: The term with id: ', $head->id(), ' has no name!' ; } else { print $output_file_handle "\n\t", obo_id2owl_id($term_id), ' -> ', obo_id2owl_id($head->id()), ';'; } } } } } # # end DOT format # print $output_file_handle "\n}"; } =head2 export2gml See - OBO::Core::Ontology::export() =cut sub export2gml { my ($self, $output_file_handle, $error_file_handle) = @_; # # begin GML format # print $output_file_handle "Creator \"ONTO-PERL, $VERSION\"\n"; print $output_file_handle "Version 1.0\n"; print $output_file_handle "graph [\n"; #print $output_file_handle "\tVendor \"ONTO-PERL\"\n"; #print $output_file_handle "\tdirected 1\n"; #print $output_file_handle "\tcomment 1" #print $output_file_handle "\tlabel 1" my %id = ('C'=>1, 'P'=>2, 'F'=>3, 'R'=>4, 'T'=>5, 'I'=>6, 'B'=>7, 'U'=>8, 'G'=>9, 'X'=>4); 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'); my %gml_id; # terms my @all_terms = @{$self->get_terms_sorted_by_id()}; foreach my $term (@all_terms) { my $term_id = $term->id(); # # Class name # print $output_file_handle "\tnode [\n"; my $term_sns = $term->subnamespace(); $term_sns = 'X' if !$term_sns; my $id = $id{$term_sns}; $gml_id{$term_id} = 100000000 * (defined($id)?$id:1) + $term->code(); #$id{$term->id()} = $gml_id; print $output_file_handle "\t\troot_index -", $gml_id{$term_id}, "\n"; print $output_file_handle "\t\tid -", $gml_id{$term_id}, "\n"; print $output_file_handle "\t\tgraphics [\n"; #print $output_file_handle "\t\t\tx 1656.0\n"; #print $output_file_handle "\t\t\ty 255.0\n"; print $output_file_handle "\t\t\tw 40.0\n"; print $output_file_handle "\t\t\th 40.0\n"; print $output_file_handle "\t\t\tfill \"#".$color_id{$term_sns}."\"\n" if $color_id{$term_sns}; print $output_file_handle "\t\t\toutline \"#000000\"\n"; print $output_file_handle "\t\t\toutline_width 1.0\n"; print $output_file_handle "\t\t]\n"; print $output_file_handle "\t\tlabel \"", $term_id, "\"\n"; print $output_file_handle "\t\tname \"", $term->name(), "\"\n"; print $output_file_handle "\t\tcomment \"", $term->def()->text(), "\"\n" if (defined $term->def()->text()); print $output_file_handle "\t]\n"; # # relationships: terms1 -> term2 # foreach my $rt ( @{$self->get_relationship_types_sorted_by_id()} ) { my %saw_rel; # avoid duplicated arrows (RelationshipSet?) my @sorted_heads = __sort_by_id(sub {lc(shift)}, @{$self->get_head_by_relationship_type($term, $rt)}); foreach my $head (grep (!$saw_rel{$_}++, @sorted_heads)) { if (!defined $term->name()) { croak 'The term with id: ', $term_id, ' has no name!' ; } elsif (!defined $head->name()) { croak 'The term with id: ', $head->id(), ' has no name!' ; } else { print $output_file_handle "\tedge [\n"; print $output_file_handle "\t\troot_index -", $gml_id{$term_id}, "\n"; print $output_file_handle "\t\tsource -", $gml_id{$term_id}, "\n"; $gml_id{$head->id()} = 100000000 * (defined($id{$head->subnamespace()})?$id{$head->subnamespace()}:1) + $head->code(); print $output_file_handle "\t\ttarget -", $gml_id{$head->id()}, "\n"; print $output_file_handle "\t\tlabel \"", $rt->name(),"\"\n"; print $output_file_handle "\t]\n"; } } } } # # end GML format # print $output_file_handle "\n]"; } =head2 export Usage - $ontology->export($export_format, $output_file_handle, $error_file_handle) Returns - exports this ontology Args - the format: obo, xml, owl, dot, gml, xgmml, sbml - the output file handle (e.g. STDOUT), and - the error file handle (STDERR by default; if not writable, STDOUT is used) Function - exports this ontology Remark - warning and errors are printed to the STDERR (by default) Remark - you may use this method to check your OBO file syntax and/or to clean it up Remark - Standard arguments: - 1. Format, one of 'obo', 'rdf', 'xml', 'owl', 'dot', 'gml', 'xgmml', 'sbml' - 2. Otput filehandle \*OUT - 3. Error filehandle \*ERR ( default \*STDERR, but for RDF or OWL ) - Extra arguments: - 'rdf': - 1. base URI (e.g. 'http://www.semantic-systems-biology.org/') - 2. name space (e.g. 'SSB') - 3. Flag, 1=construct closures, 0=no closures (default) - 4. Flag, 1=skip exporting Typedefs, 0=export Typedefs (default) - 'owl': - 1. URI for content - 2. URI for OboInOwl (optional) =cut sub export { my $self = shift; my $format = lc(shift); my $possible_formats = OBO::Util::Set->new(); $possible_formats->add_all('obo', 'rdf', 'xml', 'owl', 'dot', 'gml', 'xgmml', 'sbml'); if (!$possible_formats->contains($format)) { croak "The export format must be one of the following: 'obo', 'rdf', 'xml', 'owl', 'dot', 'gml', 'xgmml', 'sbml'"; } my $stderr_fh = \*STDERR; my $output_file_handle = shift; my $error_file_handle = shift || $stderr_fh; # check the file_handle's if (!-w $output_file_handle) { croak "export: you must provide a valid output handle, e.g. export('$format', \\*STDOUT)"; } elsif (!-e $error_file_handle) { croak "export: you must provide a valid error handle, e.g. export('$format', \\*STDOUT, \\*STDERR)"; } if (($error_file_handle eq $stderr_fh) && (!-w $error_file_handle)) { $error_file_handle = $output_file_handle; # TODO A few CPAN test platforms (e.g. solaris) don't have this handle open for testing #warn "export: the STDERR is not writable!"; } if ($format eq 'obo') { $self->export2obo($output_file_handle, $error_file_handle); } elsif ($format eq 'rdf') { my $base = shift; my $namespace = shift; my $rdf_tc = shift || 0; # Set this according to your needs: 1=reflexive relations for each term my $skip = shift || 0; # Set this according to your needs: 1=skip exporting the rel types, 0=do not skip (default) $self->export2rdf($output_file_handle, $error_file_handle, $base, $namespace, $rdf_tc, $skip); } elsif ($format eq 'xml') { $self->export2xml($output_file_handle, $error_file_handle); } elsif ($format eq 'owl') { my $oboContentUrl = shift; # e.g. 'http://www.cellcycleontology.org/ontology/owl/'; # "http://purl.org/obo/owl/"; my $oboInOwlUrl = shift; # e.g. 'http://www.cellcycleontology.org/formats/oboInOwl#'; # "http://www.geneontology.org/formats/oboInOwl#"; $self->export2owl($output_file_handle, $error_file_handle, $oboContentUrl, $oboInOwlUrl); } elsif ($format eq 'dot') { $self->export2dot($output_file_handle, $error_file_handle); } elsif ($format eq 'gml') { $self->export2gml($output_file_handle, $error_file_handle); } elsif ($format eq 'xgmml') { warn 'Not implemented yet'; } elsif ($format eq 'sbml') { warn 'Not implemented yet'; } return 0; } =head2 subontology_by_terms Usage - $ontology->subontology_by_terms($term_set) Returns - a subontology with the given terms from this ontology Args - the terms (OBO::Util::TermSet) that will be included in the subontology Function - creates a subontology based on the given terms from this ontology Remark - instances of terms (classes) are added to the resulting ontology =cut sub subontology_by_terms { my ($self, $term_set) = @_; # Future improvement: performance of this algorithm my $result = OBO::Core::Ontology->new(); foreach my $term ($term_set->get_set()) { # # add term # if (!$result->has_term($term)) { $result->add_term($term); # add term foreach my $ins ($term->class_of()->get_set()) { $result->add_instance($ins); # add its instances } } # # add descendents # foreach my $descendent (@{$self->get_descendent_terms($term)}) { if (!$result->has_term($descendent)) { $result->add_term($descendent); # add descendent foreach my $ins ($descendent->class_of()->get_set()) { $result->add_instance($ins); # add its instances } } } # # rel's # foreach my $rel (@{$self->get_relationships_by_target_term($term)}){ $result->add_relationship($rel); my $rel_type = $self->get_relationship_type_by_id($rel->type()); $result->has_relationship_type($rel_type) || $result->add_relationship_type($rel_type); } } return $result; } =head2 get_subontology_from Usage - $ontology->get_subontology_from($new_root_term) Returns - a subontology from the given term of this ontology Args - the term (OBO::Core::Term) that is the root of the subontology, and optionally, a reference to relationship type ids Function - creates a subontology having as root the given term =cut sub get_subontology_from { my ($self, $root_term, $rel_type_ids #vlmir - ref {relationsship type id => relationship type name}; optional ) = @_; my $result = OBO::Core::Ontology->new(); if ($root_term) { $self->has_term($root_term) || croak "The term '", $root_term,"' does not belong to this ontology"; $result->data_version($self->data_version()); $result->id($self->id()); $result->imports($self->imports()->get_set()); $result->idspaces($self->idspaces()->get_set()); $result->subset_def_map($self->subset_def_map()); # add (by default) all the subset_def_map's $result->synonym_type_def_set($self->synonym_type_def_set()->get_set()); # add all synonym_type_def_set by default $result->default_namespace($self->default_namespace()); $result->remarks($self->remarks()->get_set()); $result->treat_xrefs_as_equivalent($self->treat_xrefs_as_equivalent->get_set()); if ( $rel_type_ids ) { #vlmir foreach my $rel_type_id ( keys %{$rel_type_ids} ) { $result->add_relationship_type_as_string( $rel_type_id, $rel_type_ids->{$rel_type_id} ); } #vlmir } my @queue = ($root_term); while (scalar(@queue) > 0) { my $unqueued = shift @queue; $result->add_term($unqueued); foreach my $rel (@{$self->get_relationships_by_target_term($unqueued)}){ if ( $rel_type_ids ) { #vlmir $rel_type_ids->{$rel->type()} ? $result->add_relationship($rel) : next; } #vlmir else { $result->add_relationship($rel); my $rel_type = $self->get_relationship_type_by_id($rel->type()); #vlmir OBO::Core::RelationshipType $result->has_relationship_type($rel_type) || $result->add_relationship_type($rel_type); } } my @children = @{$self->get_child_terms($unqueued)}; @queue = (@queue, @children); } } return $result; } =head2 get_terms_idspace Usage - $ontology->get_terms_idspace() Returns - the idspace (e.g. GO) of the terms held by this ontology (or 'NN' is there is no idspace) Args - none Function - look for the idspace of the terms held by this ontology Remark - it is assumed that most of the terms share the same idspace (e.g. GO) =cut sub get_terms_idspace { my ($self) = @_; if ($self->id()) { return $self->id(); } else { # TODO Find an efficient way to get it... #my $is = (values(%{$self->{TERMS}}))[0]->idspace(); my $NS = undef; my @all_terms = values(%{$self->{TERMS}}); foreach my $term (@all_terms) { $NS = $term->idspace(); last if(defined $NS); } return ($NS)?$NS:'NN'; } } =head2 get_instances_idspace Usage - $ontology->get_instances_idspace() Returns - the idspace (e.g. GO) of the instances held by this ontology (or 'NN' is there is no idspace) Args - none Function - look for the idspace of the instances held by this ontology Remark - it is assumed that most of the instances share the same idspace (e.g. GO) =cut sub get_instances_idspace { my ($self) = @_; if ($self->id()) { return $self->id(); } else { # TODO Find an efficient way to get it... #my $is = (values(%{$self->{INSTANCES}}))[0]->idspace(); my $NS = undef; my @all_instances = values(%{$self->{INSTANCES}}); foreach my $instance (@all_instances) { $NS = $instance->idspace(); last if(defined $NS); } return ($NS)?$NS:'NN'; } } sub print_hasDbXref_for_owl { my ($output_file_handle, $set, $oboContentUrl, $tab_times) = @_; my $tab0 = "\t"x$tab_times; my $tab1 = "\t"x($tab_times + 1); my $tab2 = "\t"x($tab_times + 2); for my $ref ($set->get_set()) { print $output_file_handle $tab0."\n"; print $output_file_handle $tab1."\n"; my $db = $ref->db(); my $acc = $ref->acc(); # Special case when db=http and acc=www.domain.com # URL:http%3A%2F%2Fwww2.merriam-webster.com%2Fcgi-bin%2Fmwmednlm%3Fbook%3DMedical%26va%3Dforebrain # http%3A%2F%2Fwww2.merriam-webster.com%2Fcgi-bin%2Fmwmednlm%3Fbook%3DMedical%26va%3Dforebrain if ($db eq 'http') { my $http_location = &__char_hex_http($acc); print $output_file_handle $tab2."URL:http%3A%2F%2F", $http_location, "\n"; print $output_file_handle $tab2."",$http_location,"\n"; } else { print $output_file_handle $tab2."", $db, ":", $acc, "\n"; print $output_file_handle $tab2."",$oboContentUrl,$db,'#',$db,'_',$acc,"\n"; } print $output_file_handle $tab1."\n"; print $output_file_handle $tab0."\n"; } } =head2 get_descendent_terms Usage - $ontology->get_descendent_terms($term) or $ontology->get_descendent_terms($term_id) Returns - a set with the descendent terms (OBO::Core::Term) of the given term Args - the term, as an object (OBO::Core::Term) or string (e.g. GO:0003677), for which all the descendents will be found Function - returns recursively all the child terms of the given term =cut sub get_descendent_terms { my ($self, $term) = @_; my $result = OBO::Util::TermSet->new(); if ($term) { if (!eval { $term->isa('OBO::Core::Term') }) { # term is a string representing its (unique) ID (e.g. GO:0034544) $term = $self->get_term_by_id($term); } my @queue = @{$self->get_child_terms($term)}; while (scalar(@queue) > 0) { my $unqueued = pop @queue; $result->add($unqueued); my @children = @{$self->get_child_terms($unqueued)}; @queue = (@children, @queue); } } my @arr = $result->get_set(); return \@arr; } =head2 get_ancestor_terms Usage - $ontology->get_ancestor_terms($term) Returns - a set with the ancestor terms (OBO::Core::Term) of the given term Args - the term (OBO::Core::Term) for which all the ancestors will be found Function - returns recursively all the parent terms of the given term =cut sub get_ancestor_terms { my ($self, $term) = @_; my $result = OBO::Util::TermSet->new(); if ($term) { my @queue = @{$self->get_parent_terms($term)}; while (scalar(@queue) > 0) { my $unqueued = pop @queue; $result->add($unqueued); my @parents = @{$self->get_parent_terms($unqueued)}; @queue = (@parents, @queue); } } my @arr = $result->get_set(); return \@arr; } =head2 get_descendent_terms_by_subnamespace Usage - $ontology->get_descendent_terms_by_subnamespace($term, subnamespace) Returns - a set with the descendent terms (OBO::Core::Term) of the given subnamespace Args - the term (OBO::Core::Term), the subnamespace (string, e.g. 'P', 'R', 'Ia' etc) Function - returns recursively the given term's children of the given subnamespace =cut sub get_descendent_terms_by_subnamespace { my $self = shift; my $result = OBO::Util::TermSet->new(); if (@_) { my ($term, $subnamespace) = @_; my @queue = @{$self->get_child_terms($term)}; while (scalar(@queue) > 0) { my $unqueued = shift @queue; $result->add($unqueued) if substr($unqueued->id(), 4, length($subnamespace)) eq $subnamespace; my @children = @{$self->get_child_terms($unqueued)}; @queue = (@queue, @children); } } my @arr = $result->get_set(); return \@arr; } =head2 get_ancestor_terms_by_subnamespace Usage - $ontology->get_ancestor_terms_by_subnamespace($term, subnamespace) Returns - a set with the ancestor terms (OBO::Core::Term) of the given subnamespace Args - the term (OBO::Core::Term), the subnamespace (string, e.g. 'P', 'R', 'Ia' etc) Function - returns recursively the given term's parents of the given subnamespace =cut sub get_ancestor_terms_by_subnamespace { my $self = shift; my $result = OBO::Util::TermSet->new(); if (@_) { my ($term, $subnamespace) = @_; my @queue = @{$self->get_parent_terms($term)}; while (scalar(@queue) > 0) { my $unqueued = shift @queue; $result->add($unqueued) if substr($unqueued->id(), 4, length($subnamespace)) eq $subnamespace; my @parents = @{$self->get_parent_terms($unqueued)}; @queue = (@queue, @parents); } } my @arr = $result->get_set(); return \@arr; } =head2 get_descendent_terms_by_relationship_type Usage - $ontology->get_descendent_terms_by_relationship_type($term, $rel_type) Returns - a set with the descendent terms (OBO::Core::Term) of the given term linked by the given relationship type Args - OBO::Core::Term object, OBO::Core::RelationshipType object Function - returns recursively all the child terms of the given term linked by the given relationship type =cut sub get_descendent_terms_by_relationship_type { my $self = shift; my $result = OBO::Util::TermSet->new(); if (@_) { my ($term, $type) = @_; my @queue = @{$self->get_tail_by_relationship_type($term, $type)}; while (scalar(@queue) > 0) { my $unqueued = shift @queue; $result->add($unqueued); my @children = @{$self->get_tail_by_relationship_type($unqueued, $type)}; @queue = (@queue, @children); } } my @arr = $result->get_set(); return \@arr; } =head2 get_ancestor_terms_by_relationship_type Usage - $ontology->get_ancestor_terms_by_relationship_type($term, $rel_type) Returns - a set with the ancestor terms (OBO::Core::Term) of the given term linked by the given relationship type Args - OBO::Core::Term object, OBO::Core::RelationshipType object Function - returns recursively the parent terms of the given term linked by the given relationship type =cut sub get_ancestor_terms_by_relationship_type { my $self = shift; my $result = OBO::Util::TermSet->new(); if (@_) { my ($term, $type) = @_; my @queue = @{$self->get_head_by_relationship_type($term, $type)}; while (scalar(@queue) > 0) { my $unqueued = shift @queue; $result->add($unqueued); my @parents = @{$self->get_head_by_relationship_type($unqueued, $type)}; @queue = (@queue, @parents); } } my @arr = $result->get_set(); return \@arr; } =head2 get_term_by_xref Usage - $ontology->get_term_by_xref($db, $acc) 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. Args - the name of the external database and the ID (strings) Function - returns the term associated with the given external database ID =cut sub get_term_by_xref { my ($self, $db, $acc) = @_; my $result; if ($db && $acc) { foreach my $term (@{$self->get_terms()}) { # return the exact occurrence $result = $term; foreach my $xref ($term->xref_set_as_string()) { return $result if (($xref->db() eq $db) && ($xref->acc() eq $acc)); } } } return undef; } =head2 get_instance_by_xref Usage - $ontology->get_instance_by_xref($db, $acc) 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. Args - the name of the external database and the ID (strings) Function - returns the instance associated with the given external database ID =cut sub get_instance_by_xref { my ($self, $db, $acc) = @_; my $result; if ($db && $acc) { foreach my $instance (@{$self->get_instances()}) { # return the exact occurrence $result = $instance; foreach my $xref ($instance->xref_set_as_string()) { return $result if (($xref->db() eq $db) && ($xref->acc() eq $acc)); } } } return undef; } =head2 get_paths_term1_term2 Usage - $ontology->get_paths_term1_term2($term1_id, $term2_id) Returns - an array of references to the paths between term1 and term2 Args - the IDs of the terms for which a path (or paths) will be found Function - returns the path(s) linking term1 and term2, where term1 is more specific than term2 =cut sub get_paths_term1_term2 () { my ($self, $v, $bstop) = @_; my @nei = @{$self->get_parent_terms($self->get_term_by_id($v))}; my $path = $v; my @bk = ($v); my $p_id = $v; my %hijos; my %drop; my %banned; my @ruta; my @result; my $target_source_rels = $self->{TARGET_SOURCE_RELATIONSHIPS}; while ($#nei > -1) { my @back; my $n = pop @nei; # neighbours my $n_id = $n->id(); next if (!defined $p_id); # TODO investigate cases where $p_id might not be defined my $p = $self->get_term_by_id($p_id); my @ps = @{$self->get_parent_terms($n)}; my @hi = @{$self->get_parent_terms($p)}; $hijos{$p_id} = $#hi + 1; $hijos{$n_id} = $#ps + 1; push @bk, $n_id; # add the (candidate) relationship push @ruta, values(%{$target_source_rels->{$p}->{$n}}); if ($bstop eq $n_id) { #warn "\nSTOP FOUND : ", $n_id; $path .= '->'.$n_id; #warn 'PATH : ', $path; #warn 'BK : ', map {$_.'->'} @bk; #warn 'RUTA : ', map {$_->id()} @ruta; push @result, [@ruta]; } if ($#ps == -1) { # leaf my $sou = $p_id; $p_id = pop @bk; pop @ruta; #push @back, $p_id; # hold the un-stacked ones # NOTE: The following 3 lines of code are misteriously not used anymore... # banned relationship #my $source = $self->get_term_by_id($sou); #my $target = $self->get_term_by_id($p_id); #my $rr = values(%{$self->{TARGET_SOURCE_RELATIONSHIPS}->{$source}->{$target}}); $banned{$sou}++; my $hijos_sou = $hijos{$sou}; my $banned_sou = $banned{$sou}; if (defined $banned_sou && $banned_sou > $hijos_sou){ # banned rel's from source $banned{$sou} = $hijos_sou; } $drop{$bk[$#bk]}++; # if (defined $drop{$bk[$#bk]} && $drop{$bk[$#bk]} < $hijos{$p_id}); my $w = $#bk; my $bk_ww; while ( $w > -1 && ( $bk_ww = $bk[$w], ($hijos{$bk_ww} == 1 ) || (defined $drop{$bk_ww} && $hijos{$bk_ww} == $drop{$bk_ww}) || (defined $banned{$bk_ww} && $banned{$bk_ww} == $hijos{$bk_ww}) ) ) { $p_id = pop @bk; push @back, $p_id; # hold the un-stacked ones pop @ruta; $banned{$p_id}++ if ($banned{$p_id} < $hijos{$p_id}); # more banned rel's $w--; if ($w > -1) { my $bk_w = $bk[$w]; $banned{$bk_w}++; my $hijos_bk_w = $hijos{$bk_w}; my $banned_bk_w = $banned{$bk_w}; if (defined $banned_bk_w && $banned_bk_w > $hijos_bk_w) { $banned{$bk_w} = $hijos_bk_w; } } } } else { $p_id = $n_id; } push @nei, @ps; # add next level $p_id = $bk[$#bk]; $path .= '->'.$n_id; # # clean banned using the back (unstacked) # map {$banned{$_} = 0} @back; } # while return @result; } =head2 get_paths_term_terms Usage - $ontology->get_paths_term_terms($term, $set_of_terms) Returns - an array of references to the paths between a given term ID and a given set of terms IDs Args - the ID of the term (string) for which a path (or paths) will be found and a set of terms (OBO::Util::Set) Function - returns the path(s) linking the given term and the given set of terms =cut sub get_paths_term_terms () { my ($self, $v, $bstop) = @_; my @nei = @{$self->get_parent_terms($self->get_term_by_id($v))}; my $path = $v; my @bk = ($v); my $p_id = $v; my %hijos; my %drop; my %banned; my @ruta; my @result; my $target_source_rels = $self->{TARGET_SOURCE_RELATIONSHIPS}; while ($#nei > -1) { my @back; my $n = pop @nei; # neighbours my $n_id = $n->id(); next if (!defined $p_id); # TODO investigate cases where $p_id might not be defined my $p = $self->get_term_by_id($p_id); my @ps = @{$self->get_parent_terms($n)}; my @hi = @{$self->get_parent_terms($p)}; $hijos{$p_id} = $#hi + 1; $hijos{$n_id} = $#ps + 1; push @bk, $n_id; # add the (candidate) relationship push @ruta, values(%{$target_source_rels->{$p}->{$n}}); if ($bstop->contains($n_id)) { #warn "\nSTOP FOUND : ", $n_id; $path .= '->'.$n_id; #warn 'PATH : ', $path; #warn 'BK : ', map {$_.'->'} @bk; #warn 'RUTA : ', map {$_->id()} @ruta; push @result, [@ruta]; } if ($#ps == -1) { # leaf my $sou = $p_id; $p_id = pop @bk; pop @ruta; #push @back, $p_id; # hold the un-stacked ones # NOTE: The following 3 lines of code are misteriously not used... # banned relationship #my $source = $self->get_term_by_id($sou); #my $target = $self->get_term_by_id($p_id); #my $rr = values(%{$self->{TARGET_SOURCE_RELATIONSHIPS}->{$source}->{$target}}); $banned{$sou}++; my $hijos_sou = $hijos{$sou}; my $banned_sou = $banned{$sou}; if (defined $banned_sou && $banned_sou > $hijos_sou){ # banned rel's from source $banned{$sou} = $hijos_sou; } $drop{$bk[$#bk]}++; # if (defined $drop{$bk[$#bk]} && $drop{$bk[$#bk]} < $hijos{$p_id}); my $w = $#bk; my $bk_ww; while ( $w > -1 && ( $bk_ww = $bk[$w], ($hijos{$bk_ww} == 1 ) || (defined $drop{$bk_ww} && $hijos{$bk_ww} == $drop{$bk_ww}) || (defined $banned{$bk_ww} && $banned{$bk_ww} == $hijos{$bk_ww}) ) ) { $p_id = pop @bk; push @back, $p_id; # hold the un-stacked ones pop @ruta; $banned{$p_id}++ if ($banned{$p_id} < $hijos{$p_id}); # more banned rel's $w--; if ($w > -1) { my $bk_w = $bk[$w]; $banned{$bk_w}++; my $hijos_bk_w = $hijos{$bk_w}; my $banned_bk_w = $banned{$bk_w}; if (defined $banned_bk_w && $banned_bk_w > $hijos_bk_w) { $banned{$bk_w} = $hijos_bk_w; } } } } else { $p_id = $n_id; } push @nei, @ps; # add next level $p_id = $bk[$#bk]; $path .= '->'.$n_id; # # clean banned using the back (unstacked) # map {$banned{$_} = 0} @back; } # while return @result; } =head2 get_paths_term_terms_same_rel Usage - $ontology->get_paths_term_terms_same_rel($term_id, $set_of_terms, $type_of_relationship) Returns - an array of references to the paths between a given term ID and a given set of terms IDs 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 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) =cut sub get_paths_term_terms_same_rel () { my ($self, $v, $bstop, $rel) = @_; # TODO Check the case where there are reflexive relationships (e.g. GO:0000011_is_a_GO:0000011) my $r_type = $self->get_relationship_type_by_id($rel); my @nei = @{$self->get_head_by_relationship_type($self->get_term_by_id($v), $r_type)}; my $path = $v; my @bk = ($v); my $p_id = $v; my %hijos; my %drop; my %banned; my @ruta; my @result; my $target_source_rels = $self->{TARGET_SOURCE_RELATIONSHIPS}; while ($#nei > -1) { my @back; my $n = pop @nei; # neighbours my $n_id = $n->id(); next if (!defined $p_id); # TODO investigate cases where $p_id might not be defined my $p = $self->get_term_by_id($p_id); my @ps = @{$self->get_head_by_relationship_type($n, $r_type)}; my @hi = @{$self->get_head_by_relationship_type($p, $r_type)}; $hijos{$p_id} = $#hi + 1; $hijos{$n_id} = $#ps + 1; push @bk, $n_id; # add the (candidate) relationship push @ruta, values(%{$target_source_rels->{$p}->{$n}}); if ($bstop->contains($n_id)) { #warn "\nSTOP FOUND : ", $n_id; $path .= '->'.$n_id; #warn 'PATH : ', $path; #warn 'BK : ', map {$_.'->'} @bk; #warn 'RUTA : ', map {$_->id().'->'} @ruta; push @result, [@ruta]; } if ($#ps == -1) { # leaf my $sou = $p_id; $p_id = pop @bk; pop @ruta; #push @back, $p_id; # hold the un-stacked ones # NOTE: The following 3 lines of code are misteriously not used... # banned relationship #my $source = $self->get_term_by_id($sou); #my $target = $self->get_term_by_id($p_id); #my $rr = values(%{$self->{TARGET_SOURCE_RELATIONSHIPS}->{$source}->{$target}}); $banned{$sou}++; my $hijos_sou = $hijos{$sou}; my $banned_sou = $banned{$sou}; if (defined $banned_sou && $banned_sou > $hijos_sou){ # banned rel's from source $banned{$sou} = $hijos_sou; } $drop{$bk[$#bk]}++; # if (defined $drop{$bk[$#bk]} && $drop{$bk[$#bk]} < $hijos{$p_id}); my $w = $#bk; my $bk_ww; while ( $w > -1 && ( $bk_ww = $bk[$w], ($hijos{$bk_ww} == 1 ) || (defined $drop{$bk_ww} && $hijos{$bk_ww} == $drop{$bk_ww}) || (defined $banned{$bk_ww} && $banned{$bk_ww} == $hijos{$bk_ww}) ) ) { $p_id = pop @bk; push @back, $p_id; # hold the un-stacked ones pop @ruta; $banned{$p_id}++ if ($banned{$p_id} < $hijos{$p_id}); # more banned rel's $w--; if ($w > -1) { my $bk_w = $bk[$w]; $banned{$bk_w}++; my $hijos_bk_w = $hijos{$bk_w}; my $banned_bk_w = $banned{$bk_w}; if (defined $banned_bk_w && $banned_bk_w > $hijos_bk_w) { $banned{$bk_w} = $hijos_bk_w; } } } } else { $p_id = $n_id; } push @nei, @ps; # add next level $p_id = $bk[$#bk]; $path .= '->'.$n_id; # # clean banned using the back (unstacked) # map {$banned{$_} = 0} @back; } # while return @result; } =head2 obo_id2owl_id Usage - $ontology->obo_id2owl_id($term) Returns - the ID for OWL representation. Args - the OBO-type ID. Function - Transform an OBO-type ID into an OWL-type one. E.g. APO:I1234567 -> APO_I1234567 =cut sub obo_id2owl_id { $_[0] =~ tr/:/_/; return $_[0]; } =head2 owl_id2obo_id Usage - $ontology->owl_id2obo_id($term) Returns - the ID for OBO representation. Args - the OWL-type ID. Function - Transform an OWL-type ID into an OBO-type one. E.g. APO_I1234567 -> APO:I1234567 =cut sub owl_id2obo_id { $_[0] =~ tr/_/:/; return $_[0]; } =head2 __char_hex_http Usage - $ontology->__char_hex_http($seq) Returns - the sequence with the numeric HTML representation for the given special character Args - the sequence of characters Function - Transforms a character into its equivalent HTML number, e.g. : -> : =cut sub __char_hex_http { caller eq __PACKAGE__ or croak; $_[0] =~ s/:/:/g; # colon $_[0] =~ s/;/;/g; # semicolon $_[0] =~ s//>/g; # greater than sign $_[0] =~ s/\?/?/g; # question mark $_[0] =~ s/\////g; # slash $_[0] =~ s/&/&/g; # ampersand $_[0] =~ s/"/"/g; # double quotes $_[0] =~ s/�/±/g; # plus-or-minus sign # $_[0] =~ s/:/%3A/g; # $_[0] =~ s/;/%3B/g; # $_[0] =~ s//%3E/g; # $_[0] =~ s/\?/%3F/g; # $_[0] =~ s/#/%23/g; # $_[0] =~ s/$/%24/g; # $_[0] =~ s/%/%25/g; # $_[0] =~ s/\//%2F/g; # $_[0] =~ s/&/%26/g; # $_[0] =~ s/"/%22/g; # $_[0] =~ s/�/%B1/g; return $_[0]; } sub __date { caller eq __PACKAGE__ or croak; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); my $result = sprintf "%02d:%02d:%4d %02d:%02d", $mday,$mon+1,$year+1900,$hour,$min; # e.g. 11:05:2008 12:52 } sub __dfs () { caller eq __PACKAGE__ or croak; my ($self, $onto, $v) = @_; my $blist = OBO::Util::Set->new(); my $brels = OBO::Util::Set->new(); my $explored_set = OBO::Util::Set->new(); $explored_set->add($v); my @nei = @{$onto->get_parent_terms($onto->get_term_by_id($v))}; my $path = $v; my @bk = ($v); my $i = 0; my $p_id = $v; while ($#nei > -1) { my $n = pop @nei; # neighbors my $n_id = $n->id(); if ($blist->contains($n_id) || $brels->contains(values(%{$onto->{TARGET_SOURCE_RELATIONSHIPS}-> {$onto->get_term_by_id($p_id)}-> {$onto->get_term_by_id($n_id)}}))) { next; } my @ps = @{$onto->get_parent_terms($n)}; if (!$blist->contains($n_id) || !$explored_set->contains($n_id)) { $explored_set->add($n_id); push @nei, @ps; # add next level $path .= '->'.$n_id; push @bk, $n_id; $i++; } if (!@ps) { # if leaf last if (!@nei); for (my $j = 0; $j < $i; $j++) { my $e = shift @bk; $explored_set->remove($e); } @nei = @{$onto->get_parent_terms($onto->get_term_by_id($v))}; $i = 0; $path = $v; # init my $l = pop @bk; my $source = $onto->get_term_by_id($p_id); my $target = $onto->get_term_by_id($n_id); my $rr = values(%{$onto->{TARGET_SOURCE_RELATIONSHIPS}->{$source}->{$target}}); $brels->add($rr->id()); # banned terms my @crels = @{$onto->get_relationships_by_target_term($target)}; my $all_banned = 1; # assume yes... foreach my $crel (@crels) { if (!$brels->contains($crel->id())) { $all_banned = 0; last; } } if ($all_banned) { $blist->add($l); } # banned rels my @drels = @{$onto->get_relationships_by_source_term($source)}; my $all_rels_banned = 1; foreach my $drel (@drels) { if (!$brels->contains($drel->id())) { $all_rels_banned = 0; last; } } if ($all_rels_banned) { $blist->add($p_id); } @bk = ($v); $p_id = $v; next; } $p_id = $n_id; } } sub __get_name_without_whitespaces() { caller eq __PACKAGE__ or croak; $_[0] =~ s/\s+/_/g; return $_[0]; } sub __idspace_as_string { caller eq __PACKAGE__ or croak; my ($self, $local_id, $uri, $description) = @_; if ($local_id && $uri) { my $new_idspace = OBO::Core::IDspace->new(); $new_idspace->local_idspace($local_id); $new_idspace->uri($uri); $new_idspace->description($description) if (defined $description); $self->idspaces($new_idspace); return $new_idspace; } my @idspaces = $self->idspaces()->get_set(); my @idspaces_as_string = (); foreach my $idspace (@idspaces) { my $idspace_as_string = $idspace->local_idspace(); $idspace_as_string .= ' '.$idspace->uri(); my $idspace_description_string = $idspace->description(); $idspace_as_string .= ' "'.$idspace_description_string.'"' if (defined $idspace_description_string); push @idspaces_as_string, $idspace_as_string; } if (!@idspaces_as_string) { return ''; # empty string } else { return @idspaces_as_string } } sub __sort_by { caller eq __PACKAGE__ or croak; my ($subRef1, $subRef2, @input) = @_; my @result = map { $_->[0] } # restore original values sort { $a->[1] cmp $b->[1] } # sort map { [$_, &$subRef1($_->$subRef2())] } # transform: value, sortkey @input; } sub __sort_by_id { caller eq __PACKAGE__ or croak; my ($subRef, @input) = @_; my @result = map { $_->[0] } # restore original values sort { $a->[1] cmp $b->[1] } # sort map { [$_, &$subRef($_->id())] } # transform: value, sortkey @input; } 1; __END__ =head1 NAME OBO::Core::Ontology - An ontology holding terms, instances and relationships. =head1 SYNOPSIS use OBO::Core::Ontology; use OBO::Core::Term; use OBO::Core::Relationship; use OBO::Core::RelationshipType; use strict; # three new terms my $n1 = OBO::Core::Term->new(); my $n2 = OBO::Core::Term->new(); my $n3 = OBO::Core::Term->new(); # new ontology my $onto = OBO::Core::Ontology->new; $n1->id("APO:P0000001"); $n2->id("APO:P0000002"); $n3->id("APO:P0000003"); $n1->name("One"); $n2->name("Two"); $n3->name("Three"); my $def1 = OBO::Core::Def->new(); $def1->text("Definition of One"); my $def2 = OBO::Core::Def->new(); $def2->text("Definition of Two"); my $def3 = OBO::Core::Def->new(); $def3->text("Definition of Three"); $n1->def($def1); $n2->def($def2); $n3->def($def3); $onto->add_term($n1); $onto->add_term($n2); $onto->add_term($n3); $onto->delete_term($n1); $onto->add_term($n1); # new term my $n4 = OBO::Core::Term->new(); $n4->id("APO:P0000004"); $n4->name("Four"); my $def4 = OBO::Core::Def->new(); $def4->text("Definition of Four"); $n4->def($def4); $onto->delete_term($n4); $onto->add_term($n4); # add term as string my $new_term = $onto->add_term_as_string("APO:P0000005", "Five"); $new_term->def_as_string("This is a dummy definition", '[APO:vm, APO:ls, APO:ea "Erick Antezana"]'); my $n5 = $new_term; # five new relationships my $r12 = OBO::Core::Relationship->new(); my $r23 = OBO::Core::Relationship->new(); my $r13 = OBO::Core::Relationship->new(); my $r14 = OBO::Core::Relationship->new(); my $r35 = OBO::Core::Relationship->new(); $r12->id("APO:P0000001_is_a_APO:P0000002"); $r23->id("APO:P0000002_part_of_APO:P0000003"); $r13->id("APO:P0000001_participates_in_APO:P0000003"); $r14->id("APO:P0000001_participates_in_APO:P0000004"); $r35->id("APO:P0000003_part_of_APO:P0000005"); $r12->type('is_a'); $r23->type('part_of'); $r13->type("participates_in"); $r14->type("participates_in"); $r35->type('part_of'); $r12->link($n1, $n2); $r23->link($n2, $n3); $r13->link($n1, $n3); $r14->link($n1, $n4); $r35->link($n3, $n5); # get all terms my $c = 0; my %h; foreach my $t (@{$onto->get_terms()}) { $h{$t->id()} = $t; $c++; } # get terms with argument my @processes = sort {$a->id() cmp $b->id()} @{$onto->get_terms("APO:P.*")}; my @odd_processes = sort {$a->id() cmp $b->id()} @{$onto->get_terms("APO:P000000[35]")}; $onto->idspace_as_string("APO", "http://www.cellcycle.org/ontology/APO"); my @same_processes = @{$onto->get_terms_by_subnamespace("P")}; my @no_processes = @{$onto->get_terms_by_subnamespace("p")}; # add relationships $onto->add_relationship($r12); $onto->add_relationship($r23); $onto->add_relationship($r13); $onto->add_relationship($r14); $onto->add_relationship($r35); # add relationships and terms linked by this relationship my $n11 = OBO::Core::Term->new(); my $n21 = OBO::Core::Term->new(); $n11->id("APO:P0000011"); $n11->name("One one"); $n11->def_as_string("Definition One one", ""); $n21->id("APO:P0000021"); $n21->name("Two one"); $n21->def_as_string("Definition Two one", ""); my $r11_21 = OBO::Core::Relationship->new(); $r11_21->id("APO:R0001121"); $r11_21->type("r11-21"); $r11_21->link($n11, $n21); $onto->add_relationship($r11_21); # adds to the ontology the terms linked by this relationship # get all relationships my %hr; foreach my $r (@{$onto->get_relationships()}) { $hr{$r->id()} = $r; } # get children my @children = @{$onto->get_child_terms($n1)}; @children = @{$onto->get_child_terms($n3)}; my %ct; foreach my $child (@children) { $ct{$child->id()} = $child; } @children = @{$onto->get_child_terms($n2)}; # get parents my @parents = @{$onto->get_parent_terms($n3)}; @parents = @{$onto->get_parent_terms($n1)}; @parents = @{$onto->get_parent_terms($n2)}; # get all descendents my @descendents1 = @{$onto->get_descendent_terms($n1)}; my @descendents2 = @{$onto->get_descendent_terms($n2)}; my @descendents3 = @{$onto->get_descendent_terms($n3)}; my @descendents5 = @{$onto->get_descendent_terms($n5)}; # get all ancestors my @ancestors1 = @{$onto->get_ancestor_terms($n1)}; my @ancestors2 = @{$onto->get_ancestor_terms($n2)}; my @ancestors3 = @{$onto->get_ancestor_terms($n3)}; # get descendents by term subnamespace my @descendents4 = @{$onto->get_descendent_terms_by_subnamespace($n1, 'P')}; my @descendents5 = @{$onto->get_descendent_terms_by_subnamespace($n2, 'P')}; my @descendents6 = @{$onto->get_descendent_terms_by_subnamespace($n3, 'P')}; my @descendents6 = @{$onto->get_descendent_terms_by_subnamespace($n3, 'R')}; # get ancestors by term subnamespace my @ancestors4 = @{$onto->get_ancestor_terms_by_subnamespace($n1, 'P')}; my @ancestors5 = @{$onto->get_ancestor_terms_by_subnamespace($n2, 'P')}; my @ancestors6 = @{$onto->get_ancestor_terms_by_subnamespace($n3, 'P')}; my @ancestors6 = @{$onto->get_ancestor_terms_by_subnamespace($n3, 'R')}; # three new relationships types my $r1 = OBO::Core::RelationshipType->new(); my $r2 = OBO::Core::RelationshipType->new(); my $r3 = OBO::Core::RelationshipType->new(); $r1->id("APO:R0000001"); $r2->id("APO:R0000002"); $r3->id("APO:R0000003"); $r1->name('is_a'); $r2->name('part_of'); $r3->name("participates_in"); # add relationship types $onto->add_relationship_type($r1); $onto->add_relationship_type($r2); $onto->add_relationship_type($r3); # get descendents or ancestors linked by a particular relationship type my $rel_type1 = $onto->get_relationship_type_by_name('is_a'); my $rel_type2 = $onto->get_relationship_type_by_name('part_of'); my $rel_type3 = $onto->get_relationship_type_by_name("participates_in"); my @descendents7 = @{$onto->get_descendent_terms_by_relationship_type($n5, $rel_type1)}; @descendents7 = @{$onto->get_descendent_terms_by_relationship_type($n5, $rel_type2)}; @descendents7 = @{$onto->get_descendent_terms_by_relationship_type($n2, $rel_type1)}; @descendents7 = @{$onto->get_descendent_terms_by_relationship_type($n3, $rel_type3)}; my @ancestors7 = @{$onto->get_ancestor_terms_by_relationship_type($n1, $rel_type1)}; @ancestors7 = @{$onto->get_ancestor_terms_by_relationship_type($n1, $rel_type2)}; @ancestors7 = @{$onto->get_ancestor_terms_by_relationship_type($n1, $rel_type3)}; @ancestors7 = @{$onto->get_ancestor_terms_by_relationship_type($n2, $rel_type2)}; # add relationship type as string my $relationship_type = $onto->add_relationship_type_as_string("APO:R0000004", "has_participant"); # get relationship types my @rt = @{$onto->get_relationship_types()}; my %rrt; foreach my $relt (@rt) { $rrt{$relt->name()} = $relt; } my @rtbt = @{$onto->get_relationship_types_by_term($n1)}; my %rtbth; foreach my $relt (@rtbt) { $rtbth{$relt} = $relt; } # get_head_by_relationship_type my @heads_n1 = @{$onto->get_head_by_relationship_type($n1, $onto->get_relationship_type_by_name("participates_in"))}; my %hbrt; foreach my $head (@heads_n1) { $hbrt{$head->id()} = $head; } =head1 DESCRIPTION This module supports the manipulation of OBO-formatted ontologies, such as the Gene Ontology (http://www.geneontology.org/) or the Cell Cycle Ontology (http://www.cellcycleontology.org). Basically, it represents a directed acyclic graph (DAG) holding terms (OBO::Core::Term) which in turn are linked by relationships (OBO::Core::Relationship). Those relationships have an associated relationship type (OBO::Core::RelationshipType). =head1 AUTHOR Erick Antezana, Eerick.antezana -@- gmail.comE =head1 COPYRIGHT AND LICENSE Copyright (c) 2006-2012 by Erick Antezana This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.7 or, at your option, any later version of Perl 5 you may have available. =cut