[Bio] / FigKernelPackages / NCBI_taxonomy.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/NCBI_taxonomy.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3, Sun Jan 2 23:43:13 2011 UTC revision 1.4, Sat Jan 22 00:13:29 2011 UTC
# Line 19  Line 19 
19  #  #
20  #  Keys:  #  Keys:
21  #  #
22  #      CommonName                 #  Common name  #      CommonName                 # Common name (might be a list)
23  #      Division                   #  GenBank division (not 3-letter abbrev)  #      Division                   #  GenBank division (not 3-letter abbrev)
24  #      GeneticCode                #  Genetic code number  #      GeneticCode                #  Genetic code number
25  #      Lineage                    #  Lineage text, semicolon separated  #      Lineage                    # Full lineage text, semicolon separated
26  #      LineageAbbrev              #  Lineage text, semicolon separated  #      LineageAbbrev              # Abbreviated lineage text, semicolon sep.
27  #      LineageExIds               #  List of full lineage taxids  #      LineageAbbrevIds           # List of abbreviated lineage ids
28    #      LineageAbbrevNames         # List of abbreviated lineage names
29    #      LineageAbbrevPlus          # Abbreviated lineage with full lineage suffix
30    #      LineageAbbrevPlusIds       # List of LineageAbbrevPlus ids
31    #      LineageAbbrevPlusNames     # List of LineageAbbrevPlus names
32    #      LineageExIds               # See LineageIds
33    #      LineageIds                 # List of full lineage taxids
34  #      LineageExNames             #  List of full lineage names  #      LineageExNames             #  List of full lineage names
35    #      LineageNames               # See LineageNames
36  #      MitochondrialGeneticCode   #  Mitochondrial genetic code number  #      MitochondrialGeneticCode   #  Mitochondrial genetic code number
37  #      Parent                     #  Parent node taxid  #      Parent                     #  Parent node taxid
38  #      Rank                       #  Rank  #      Rank                       #  Rank
# Line 46  Line 53 
53  #  #
54  #  The last form returns the XML hierarchy in perl lists of the form:  #  The last form returns the XML hierarchy in perl lists of the form:
55  #  #
56  #      [ tag, [ enclused_items, ... ] ]  #      [ tag, [ enclosed_items, ... ] ]
57  #  #
58  #-------------------------------------------------------------------------------  #-------------------------------------------------------------------------------
59  #  It does not seem to be possible to get the short lineage without loading  #  It does not seem to be possible to get the short lineage without loading
# Line 91  Line 98 
98               GCId            => [ qw( Taxon GeneticCode GCId ) ],               GCId            => [ qw( Taxon GeneticCode GCId ) ],
99               GeneticCode     => [ qw( Taxon GeneticCode GCId ) ],               GeneticCode     => [ qw( Taxon GeneticCode GCId ) ],
100               Lineage         => [ qw( Taxon Lineage ) ],               Lineage         => [ qw( Taxon Lineage ) ],
101               LineageExIds    => [ qw( Taxon LineageEx Taxon TaxId ) ],               LineageIds      => [ qw( Taxon LineageEx Taxon TaxId ) ],
102               LineageExNames  => [ qw( Taxon LineageEx Taxon ScientificName ) ],               LineageNames    => [ qw( Taxon LineageEx Taxon ScientificName ) ],
103               MGCId           => [ qw( Taxon MitoGeneticCode MGCId ) ],               MGCId           => [ qw( Taxon MitoGeneticCode MGCId ) ],
104               MitoGeneticCode => [ qw( Taxon MitoGeneticCode MGCId ) ],               MitoGeneticCode => [ qw( Taxon MitoGeneticCode MGCId ) ],
105               Parent          => [ qw( Taxon ParentTaxId ) ],               Parent          => [ qw( Taxon ParentTaxId ) ],
# Line 107  Line 114 
114  sub taxonomy  sub taxonomy
115  {  {
116      my $taxid = shift;      my $taxid = shift;
117        return undef unless defined $taxid && $taxid =~ s/^(\d+)/$1/;
118    
119      my $options = ( ! @_ || ! $_[0] )           ? { key => 'Lineage'  }      my $options = ( ! @_ || ! $_[0] )           ? { key => 'Lineage'  }
120                  : ( ! ref( $_[0] ) )            ? { key => $_[0]      }                  : ( ! ref( $_[0] ) )            ? { key => $_[0]      }
# Line 114  Line 122 
122                  : (   ref( $_[0] ) ne 'HASH' )  ? { key => 'Lineage'  }                  : (   ref( $_[0] ) ne 'HASH' )  ? { key => 'Lineage'  }
123                  :                                 $_[0];                  :                                 $_[0];
124    
125        #  This is the only instance in which we do not need the XML:
126    
127        my $ps_key = pseudo_key( $options->{ key } );
128        if ( $ps_key eq 'LineageAbbrev' )
129        {
130            my $datum = lineage_abbreviated( $taxid );
131            return wantarray ? ( $datum ) : [ $datum ];
132        }
133    
134      my $taxon_xml = taxonomy_xml( $taxid );      my $taxon_xml = taxonomy_xml( $taxid );
     # print Dumper( $taxon_xml ); exit;  
135      return () unless $taxon_xml && ref( $taxon_xml ) eq 'ARRAY' &&  @$taxon_xml;      return () unless $taxon_xml && ref( $taxon_xml ) eq 'ARRAY' &&  @$taxon_xml;
136    
137      #  XML      #  XML
138    
139      return $taxon_xml  if $options->{ xml };      return $taxon_xml  if $options->{ xml };
140    
141      #  Hash of keys and values      #  Hash of keys and values, or an type that we need to derive
142    
143        if ( $options->{ hash } || $ps_key )
144        {
145            my %results = ();
146    
147            #  These are the keys for deriving lineages:
148    
149            foreach my $key ( qw( Lineage LineageNames LineageIds ) )
150            {
151                my @values = taxonomy_datum( $taxon_xml, @{ $path{ $key } } );
152                $results{ $key } = \@values if @values;
153            }
154    
155            #  These will probably never happen, but it could be useful:
156    
157            my $Lineage = $results{ Lineage } && @{ $results{ Lineage } } ? $results{ Lineage }->[0] : '';
158            if ( ! $results{ LineageNames } && $Lineage )
159            {
160                $results{ LineageNames } = text2list( $Lineage );
161            }
162    
163            if ( ! $Lineage && $results{ LineageNames } && @{ $results{ LineageNames } } )
164            {
165                $results{ Lineage } = list2text( $results{ LineageNames } );
166                $Lineage = $results{ Lineage }->[0]
167            }
168    
169            #  Get the abbreviated lineage:
170    
171            my $LineageAbbrev = lineage_abbreviated( $taxid );
172            $results{ LineageAbbrev } = [ $LineageAbbrev ];
173    
174            if ( $LineageAbbrev )
175            {
176                my $AbbrevNames = text2list( $LineageAbbrev );
177                return wantarray ? @$AbbrevNames : $AbbrevNames if $ps_key eq 'LineageAbbrevNames';
178    
179                my %id;
180                my $LineageIds   = $results{ LineageIds };
181                my $LineageNames = $results{ LineageNames };
182                if ( $LineageIds && $LineageNames && @$LineageIds == @$LineageNames )
183                {
184                    for ( my $i = 0; $i < @$LineageIds; $i++ )
185                    {
186                        $id{ $LineageNames->[ $i ] } = $LineageIds->[ $i ];
187                    }
188    
189                    my $AbbrevIds = [ map { $id{ $_ } } @$AbbrevNames ];
190                    return wantarray ? @$AbbrevIds : $AbbrevIds if $ps_key eq 'LineageAbbrevIds';
191    
192                    $results{ LineageAbbrevIds } = $AbbrevIds;
193                }
194    
195                $results{ LineageAbbrevNames } = $AbbrevNames;
196    
197                #  There is a peculiarity of the abbreviated lineage that it does not
198                #  include the species binomial.  We will add LineageAbbrevPlus, which
199                #  adds a suffix of categories at the end of the full lineage, but not
200                #  in the abbreviated lineage.
201    
202                if ( $LineageNames && @$LineageNames )
203                {
204                    my @suffix = ();
205                    foreach ( reverse @$LineageNames )
206                    {
207                        last if $_ eq $AbbrevNames->[-1];
208                        push @suffix, $_;
209                    }
210                    # die "NCBI_taxonomy::taxonomy: Terminal taxon in abbreviated lineage not found in full lineage.\n    $LineageAbbrev\n    $Lineage\n" if @suffix == @$LineageNames;
211    
212                    @suffix = () if @suffix == @$LineageNames;
213                    my $AbbrevPlusNames = [ @$AbbrevNames, @suffix ];
214    
215                    return wantarray ? @$AbbrevPlusNames : $AbbrevPlusNames if $ps_key eq 'LineageAbbrevPlusNames';
216    
217                    my $AbbrevPlusIds = keys %id ? [ map { $id{ $_ } } @$AbbrevPlusNames ] : undef;
218    
219                    return wantarray ? @$AbbrevPlusIds : $AbbrevPlusIds if $ps_key eq 'LineageAbbrevPlusIds';
220    
221                    my $AbbrevPlus = list2text( $AbbrevPlusNames );
222                    return wantarray ? @$AbbrevPlus : $AbbrevPlus if $ps_key eq 'LineageAbbrevPlus';
223    
224                    $results{ LineageAbbrevPlusNames } = $AbbrevPlusNames;
225                    $results{ LineageAbbrevPlusIds   } = $AbbrevPlusIds  if $AbbrevPlusIds;
226                    $results{ LineageAbbrevPlus      } = $AbbrevPlus;
227                }
228            }
229    
230            #  These are other keys that we can get from the XML:
231    
232      my @keys = qw( CommonName      my @keys = qw( CommonName
233                     Division                     Division
234                     GeneticCode                     GeneticCode
                    Lineage  
                    LineageExIds  
                    LineageExNames  
235                     MitochondrialGeneticCode                     MitochondrialGeneticCode
236                     Parent                     Parent
237                     Rank                     Rank
238                     ScientificName                     ScientificName
239                   );                   );
     if ( $options->{ hash } )  
     {  
         my %results = ();  
240          foreach my $key ( @keys )          foreach my $key ( @keys )
241          {          {
242              my @values = taxonomy_datum( $taxon_xml, @{ $path{ $key } } );              my @values = taxonomy_datum( $taxon_xml, @{ $path{ $key } } );
243              $results{ $key } = \@values if @values;              $results{ $key } = \@values if @values;
244          }          }
245          $results{ LineageAbbrev } = [ lineage_abbreviated( $taxid ) ];  
246          return \%results;          return \%results;
247      }      }
248    
249      my $path = $options->{ path };      my $path = $options->{ path };
250      if ( $path && ( ref( $path ) eq 'ARRAY' ) && @$path ) {}      if ( ! ( $path && ( ref( $path ) eq 'ARRAY' ) && @$path ) )
     else  
251      {      {
252          my $key = cannonical_key( $options->{ key } );          my $key = cannonical_key( $options->{ key } );
         if ( $key eq 'LineageAbbrev' )  
         {  
             my $datum = lineage_abbreviated( $taxid );  
             return wantarray ? ( $datum ) : [ $datum ];  
         }  
253          $path = $path{ $key };          $path = $path{ $key };
254      }      }
255    
# Line 166  Line 259 
259  }  }
260    
261    
262    sub text2list { [ split /; +/, $_[0] ] }
263    
264    
265    sub list2text { [ join '; ', @{ $_[0] } ] }
266    
267    
268    #  These are not in the XML, but we can build them:
269    
270    sub pseudo_key
271    {
272        local $_ = shift || '';
273        return  m/Abb.*Pl.*Nam/i ? 'LineageAbbrevPlusNames' :
274                m/Abb.*Pl.*Id/i  ? 'LineageAbbrevPlusIds'   :
275                m/Abb.*Pl/i      ? 'LineageAbbrevPlus'      :
276                m/Abb.*Nam/i     ? 'LineageAbbrevNames'     :
277                m/Abb.*Id/i      ? 'LineageAbbrevIds'       :
278                m/Abb/i          ? 'LineageAbbrev'          :
279                m/^Lin.*Sh/i     ? 'LineageAbbrev'          :  # LineageShort
280                                   '';
281    }
282    
283    
284  sub cannonical_key  sub cannonical_key
285  {  {
286      local $_ = shift || '';      local $_ = shift || '';
# Line 174  Line 289 
289              m/^Com/i      ? 'CommonName'               :              m/^Com/i      ? 'CommonName'               :
290              m/^Div/i      ? 'Division'                 :              m/^Div/i      ? 'Division'                 :
291              m/^Gen/i      ? 'GeneticCode'              :              m/^Gen/i      ? 'GeneticCode'              :
292              m/^Lin.*Id/i  ? 'LineageExIds'             :              m/^Lin.*Id/i      ? 'LineageIds'               :
293              m/^Lin.*Nam/i ? 'LineageExNames'           :              m/^Lin.*Nam/i     ? 'LineageNames'             :
             m/^Lin.*Ab/i  ? 'LineageAbbrev'             :  
             m/^Lin.*Sh/i  ? 'LineageAbbrev'             :  
294              m/^Lin/i      ? 'Lineage'                  :              m/^Lin/i      ? 'Lineage'                  :
295              m/^Mit/i      ? 'MitochondrialGeneticCode' :              m/^Mit/i      ? 'MitochondrialGeneticCode' :
296              m/^Par/i      ? 'Parent'                   :              m/^Par/i      ? 'Parent'                   :
# Line 220  Line 333 
333                   map  { xml_unescape( $_ ) }         # Decode HTML body content                   map  { xml_unescape( $_ ) }         # Decode HTML body content
334                   map  { chomp; s/^\s+//; s/\s+$//; $_ }                   map  { chomp; s/^\s+//; s/\s+$//; $_ }
335                   SeedAware::run_gathering_output( $curl, '-s', "$url?$request" );                   SeedAware::run_gathering_output( $curl, '-s', "$url?$request" );
   
336      ( xml_items( \@return, undef ) )[0];      ( xml_items( \@return, undef ) )[0];
337  }  }
338    
# Line 242  Line 354 
354      local $_ = shift @$list;      local $_ = shift @$list;
355      return undef if ! $_ || defined $close && /^<\/$close>/;      return undef if ! $_ || defined $close && /^<\/$close>/;
356      die "Bad closing tag '$_'." if /^<\//;      die "Bad closing tag '$_'." if /^<\//;
357      return( [ $1, xml_unescape($2) ] ) if /^<(\S+)>(.+)<\/(\S+)>$/ && $1 eq $3;      return( [ $1, xml_unescape($2) ] ) if /^<(\S+)>(.*)<\/(\S+)>$/ && $1 eq $3;
358      return( [ $1, $1 ] ) if /^<(\S+)\s*\/>$/;      return( [ $1, $1 ] ) if /^<(\S+)\s*\/>$/;
359      die "Bad line '$_'." if ! /^<(\S+)>$/;      die "Bad line '$_'." if ! /^<(\S+)>$/;
360      [ xml_items( $list, $1 ) ];      [ xml_items( $list, $1 ) ];

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3