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

Diff of /FigKernelPackages/gjogenbank.pm

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

revision 1.7, Sun Jan 2 18:54:32 2011 UTC revision 1.8, Mon Jan 24 00:05:10 2011 UTC
# Line 216  Line 216 
216  }  }
217    
218    
219    #  Qualifiers that do not require values:
220    
221    my %valueless_qual = map { $_ => 1 }
222                         qw( artificial_location
223                             environmental_sample
224                             focus
225                             germline
226                             macronuclear
227                             partial
228                             proviral
229                             pseudo
230                             rearranged
231                             ribosomal_slippage
232                             transgenic
233                             trans_splicing
234                          );
235    
236    
237  #===============================================================================  #===============================================================================
238  #  #
239  #    @entries = parse_genbank( )           #  \*STDIN  #    @entries = parse_genbank( )           #  \*STDIN
# Line 483  Line 501 
501          }          }
502      }      }
503    
504        #
505      #  Reading FEATURES requires merging continuations, then dealing      #  Reading FEATURES requires merging continuations, then dealing
506      #  with the data:      #  with the data:
507        #
508      while ( $state == 2 && ( /^     (\S+)\s+(\S+)/ ) )      while ( $state == 2 && ( /^     (\S+)\s+(\S+)/ ) )
509      {      {
510          my ( $type, $loc ) = ( $1, $2 );          my ( $type, $loc ) = ( $1, $2 );
# Line 507  Line 526 
526              #  Qualifiers without = get an undef value (intentionally)              #  Qualifiers without = get an undef value (intentionally)
527    
528              ( $qualif, undef, $value ) = /^\s*\/(\w+)(=(.*))?/;              ( $qualif, undef, $value ) = /^\s*\/(\w+)(=(.*))?/;
   
529              #  Quoted strings can have value lines that start with /, so              #  Quoted strings can have value lines that start with /, so
530              #  we must track quotation marks.              #  we must track quotation marks.
531    
# Line 518  Line 536 
536              {              {
537                  s/^ +//;                  s/^ +//;
538                  $nquote += tr/"//;                  $nquote += tr/"//;
539                  $value  .= " $_";                  $value  .= ( $value =~ /\S-$/ ? '' : ' ' ) . $_;
540                  if ( defined( $_ = <$fh> ) ) { chomp } else { $state = -1 }                  if ( defined( $_ = <$fh> ) ) { chomp } else { $state = -1 }
541              }              }
542    
# Line 530  Line 548 
548    
549              if ( $qualif )              if ( $qualif )
550              {              {
551                  if ( $value && $value =~ s/^"(.*)"$/$1/ ) { $value =~ s/""/"/g }                  if ( $valueless_qual{ $qualif } )
552                  if ( $qualif eq 'translation' ) { $value =~ s/ +//g }                  {
553                        $value = 1;
554                    }
555                    elsif ( ! defined $value || ! length $value )
556                    {
557                        next;
558                    }
559                    else
560                    {
561                        $value =~ s/""/"/g  if $value =~ s/^"(.*)"$/$1/;
562                        $value =~ s/ +//g   if $qualif eq 'translation';
563                    }
564    
565                  push @qualif_order, $qualif  if ! $qualifs{ $qualif };                  push @qualif_order, $qualif  if ! $qualifs{ $qualif };
566                  push @{ $qualifs{ $qualif } }, $value;                  push @{ $qualifs{ $qualif } }, $value;
# Line 557  Line 586 
586              $state = 4;              $state = 4;
587          }          }
588    
589            #  2011/01/23 -- GJO
590            #
591            #  NCBI has stopped including BASE COUNT.  Their example is a disaster
592            #  (http://www.ncbi.nlm.nih.gov/genbank/genomesubmit-Examples.html):
593            #
594            #  BASE COUNT  1165552 a 648314 c 647106 g1169556 t
595            #  ORIGIN
596            #
597          elsif ( s/^BASE COUNT\s+// )          elsif ( s/^BASE COUNT\s+// )
598          {          {
599              $entry{ BASE_COUNT } = { reverse split };              #  $entry{ BASE_COUNT } = { reverse split };
600              if ( defined( $_ = <$fh> ) ) { chomp } else { $state = -1 }              if ( defined( $_ = <$fh> ) ) { chomp } else { $state = -1 }
601          }          }
602    
# Line 1632  Line 1669 
1669      write_references( $entry );      write_references( $entry );
1670      write_comment( $entry )      if $entry->{ COMMENT };      write_comment( $entry )      if $entry->{ COMMENT };
1671      write_features( $entry );      write_features( $entry );
1672      write_base_count( $entry );      #  write_base_count( $entry );  #  Just not useful, and error prone
1673      write_origin( $entry );      write_origin( $entry );
1674      write_sequence( $entry );      write_sequence( $entry );
1675      write_end_of_entry();      write_end_of_entry();
# Line 1977  Line 2014 
2014  }  }
2015    
2016    
2017    #  2011/01/23 -- GJO
2018    #
2019    #  Not required, and introduces more problems than it solves.
2020    #
2021  sub write_base_count  sub write_base_count
2022  {  {
2023      my $entry = shift;      return;
2024      return if $entry->{ is_protein };  #
2025      return if $entry->{ mol_type } =~ /\S/ && $entry->{ mol_type } !~ m/NA$/i;  #    my $entry = shift;
2026    #    return if $entry->{ is_protein };
2027      my ( $a, $c, $g, $t, $o );  #    return if $entry->{ mol_type } =~ /\S/ && $entry->{ mol_type } !~ m/NA$/i;
2028      my $counts = $entry->{ BASE_COUNT };  #
2029      if ( $counts && ref $counts eq 'HASH' && keys %$counts)  #    my ( $a, $c, $g, $t, $o );
2030      {  #    my $counts = $entry->{ BASE_COUNT };
2031          ( $a, $c, $g, $t, $o ) = map { $counts->{ $_ } || 0 }  #    if ( $counts && ref $counts eq 'HASH' && keys %$counts)
2032                                   qw( a c g t other );  #    {
2033          $a || $c || $g || $t || $o or return;  #        ( $a, $c, $g, $t, $o ) = map { $counts->{ $_ } || 0 }
2034      }  #                                 qw( a c g t other );
2035      else  #        $a || $c || $g || $t || $o or return;
2036      {  #    }
2037          $entry->{ SEQUENCE } or return;  #    else
2038          my $s = \$entry->{ SEQUENCE };  #    {
2039          $a = $$s =~ tr/Aa//;  #        $entry->{ SEQUENCE } or return;
2040          $c = $$s =~ tr/Cc//;  #        my $s = \$entry->{ SEQUENCE };
2041          $g = $$s =~ tr/Gg//;  #        $a = $$s =~ tr/Aa//;
2042          $t = $$s =~ tr/Tt//;  #        $c = $$s =~ tr/Cc//;
2043          $o = length( $$s ) - ( $a + $c + $g + $t );  #        $g = $$s =~ tr/Gg//;
2044          $a || $c || $g || $t || $o or return;  #        $t = $$s =~ tr/Tt//;
2045    #        $o = length( $$s ) - ( $a + $c + $g + $t );
2046          $entry->{ BASE_COUNT } = { a => $a,  #        $a || $c || $g || $t || $o or return;
2047                                     c => $c,  #
2048                                     g => $g,  #        $entry->{ BASE_COUNT } = { a => $a,
2049                                     t => $t  #                                   c => $c,
2050                                   };  #                                   g => $g,
2051          $entry->{ BASE_COUNT }->{ other } = $o if $o;  #                                   t => $t
2052      }  #                                 };
2053    #        $entry->{ BASE_COUNT }->{ other } = $o if $o;
2054      printf "BASE COUNT  %6d a %6dc %6d g %6d t%s\n",  #    }
2055             $a, $c, $g, $t, $o ? sprintf( ' %6d', $o ) : '';  #
2056    #    printf "BASE COUNT  %6d a %6d c %6d g %6d t%s\n",
2057    #           $a, $c, $g, $t, $o ? sprintf( ' %6d other', $o ) : '';
2058  }  }
2059    
2060    

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3