[MOBY-guts] biomoby commit

[Mark Wilkinson]

mwilkinson
Thu Feb 20 23:10:25 EST 2003
Update of /home/repository/moby/moby-live/Perl/MOBY
In directory pub.open-bio.org:/tmp/cvs-serv30440/MOBY

Modified Files:
	Central.pm 
Log Message:
new function 'ISA' to ask MOBY Central for the parentage and container status of an object.  useful if a service passes you something you have never seen before.
moby-live/Perl/MOBY Central.pm,1.6,1.7
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Central.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- /home/repository/moby/moby-live/Perl/MOBY/Central.pm	2003/02/21 00:15:44	1.6
+++ /home/repository/moby/moby-live/Perl/MOBY/Central.pm	2003/02/21 04:10:25	1.7
@@ -2366,7 +2366,7 @@
 =head2 retrieveObject
 
  Title     :	retrieveObject
- Usage     :	$objects = $MOBY->retrieveObject($name | "all")
+ Usage     :	$objects = $MOBY->retrieveObject($inputXML)
  Function  :	get the object xsd
  Returns   :	XML (see below)
  Args      :	$name - object name (from ontology) or "all" to get all objects
@@ -2420,14 +2420,11 @@
 }
 
 
-
 sub _retrieveObjectPayload {
 
 	my ($payload) = @_;
 	my $Parser = new XML::DOM::Parser;
-	$debug && &_LOG("2retrieveObject $payload\n");
 	my $doc = $Parser->parse($payload);
-	$debug && &_LOG("3retrieveObject $payload\n");
 	my $Object = $doc->getDocumentElement();
 	my $obj = $Object->getTagName;
 	return undef unless ($obj eq 'retrieveObject');
@@ -2435,6 +2432,115 @@
 	return ($type);
 }
 
+
+
+=head2 ISA
+
+ Title     :	ISA
+ Usage     :	$objects = $MOBY->ISA($input_XML)
+ Function  :	get the object xsd
+ Returns   :	XML (see below)
+ Args      :	$name - object name (from ontology) or "all" to get all objects
+ 
+ inputXML  :
+	<ISA>
+	 <objectType>QueryObject</objectType>
+	<ISA>
+			  
+ outputXML       :
+	<Relationships>
+	   <objectType>QueryObject</objectType>
+		  <ISA>
+			  <objectType>ParentObject</objectType>
+			  ...
+			  ...
+		  </ISA>
+		  <HASA>
+			  <objectType>ContainedObject</objectType>
+			  ...
+			  ...
+		  </HASA>
+	</Relationships>
+
+=cut
+
+
+
+sub ISA {
+	my ($pkg, $payload) = @_;
+	my $obj = &_ISAPayload($payload);
+	my ($dbh, $sth_hash) = &_dbAccess;
+	my %sth = %{$sth_hash};
+	my ($isa) = $dbh->selectrow_array("select id from RelationshipType where type = 'is a'");
+	my ($hasa) = $dbh->selectrow_array("select id from RelationshipType where type = 'has a'");
+	
+	my %isa; my %hasa;
+	&_flatten($dbh, $isa, $obj, \%isa);
+	&_flatten($dbh, $hasa, $obj, \%isa);
+	
+	my $response = "
+	<Relationships>
+		<objectType>$obj</objectType>
+		<ISA>
+	";
+	foreach (keys %isa){
+		$response .= "<objectType>$_</objectType>";
+	}
+	$response .= "
+		</ISA>
+		<HASA>
+	";
+	foreach (keys %hasa){
+		$response .= "<objectType>$_</objectType>";
+	}
+	$response .= "
+		</HASA>
+	</Relationships>
+	";
+
+	return $response;	
+	
+}
+
+sub _flatten {
+	# from a given term, traverse the ontology
+	# and flatten it into a list of parent terms
+	my ($dbh,$type,$term, $seen) = @_;
+	my $sth = $dbh->prepare("
+	select
+		OE1.term
+	from
+		OntologyEntry as OE1,
+		OntologyEntry as OE2,
+		Term2Term as TT
+	where
+		ontologyentry2_id = OE2.id
+		and ontologyentry1_id = OE1.id
+		and relationship_type_id = $type
+		and OE2.term = ?"
+								);
+	$sth->execute($term);
+	while (my ($term) = $sth->fetchrow_array){
+		next if ${$seen}{$term};
+		&_flatten($dbh, $type, $term, $seen);
+		${$seen}{$term} = 1;
+	}
+	
+}		
+
+sub _ISAPayload {
+
+	my ($payload) = @_;
+	my $Parser = new XML::DOM::Parser;
+	my $doc = $Parser->parse($payload);
+	my $Object = $doc->getDocumentElement();
+	my $obj = $Object->getTagName;
+	return undef unless ($obj eq 'ISA');
+	my $type = &_nodeTextContent($Object, "objectType");
+	return ($type);
+}
+
+
 =cut