view release on metacpan or  search on metacpan

Bio/DB/GFF/Adaptor/biofetch.pm  view on Meta::CPAN

  }

  my $seq  = eval {$biofetch->get_Seq_by_id($acc)} or return;
  $self->_load_embl($acc,$seq);
  1;
}

sub load_from_file {
  my $self = shift;
  my $file = shift;

  my $format = $file =~ /\.(gb|genbank|gbk)$/i ? 'genbank' : 'embl';

  my $seqio = Bio::SeqIO->new( '-format' => $format, -file => $file);
  my $seq   = $seqio->next_seq;

  $self->_load_embl($seq->accession,$seq);
  1;
}

sub _load_embl {
  my $self = shift;
  my $acc  = shift;
  my $seq  = shift;
  my $refclass = $self->refclass;
  my $locus    = $seq->id;
  my $source   = $self->_source;

  # begin loading
  $self->setup_load();

  # first synthesize the entry for the top-level feature
  my @aliases;
  foreach ($seq->accession,$seq->get_secondary_accessions) {
    next if lc($_) eq lc($acc);
    push @aliases,[Alias => $_];
  }
  $self->load_gff_line(
		       {
			ref    => $acc,
			class  => $refclass,
			source => $source,
#			method => 'origin',
			method => 'region',
			start  => 1,
			stop   => $seq->length,
			score  => undef,
			strand => '.',
			phase  => '.',
			gclass => $self->refclass,
			gname  => $acc,
			tstart => undef,
			tstop  => undef,
			attributes  => [[Note => $seq->desc],@aliases],
		       }
		      );
  # now load each feature in turn
  my ($transcript_version,$mRNA_version) = (0,0);
  for my $feat ($seq->all_SeqFeatures) {
    my $attributes = $self->get_attributes($feat);
    my $name       = $self->guess_name($attributes);

    my $location = $feat->location;
    my @segments = map {[$_->start,$_->end,$_->seq_id]}
      $location->can('sub_Location') ? $location->sub_Location : $location;

# this changed CDS to coding, but that is the wrong thing to do, since
# CDS is in SOFA and coding is not
#    my $type     =   $feat->primary_tag eq 'CDS'   ? 'coding'
#                   : $feat->primary_tag;
    my $type=  $feat->primary_tag;
    next if (lc($type) eq 'contig');
#    next if (lc($type) eq 'variation');

    if (lc($type) eq 'variation' and $feat->length == 1) {
      $type = 'SNP';
    } elsif (lc($type) eq 'variation' ) {
      $type = 'chromosome_variation';
    }

    if ($type  eq 'source') {
      $type = 'region';
    }

    if ($type =~ /misc.*RNA/i) {
      $type = 'RNA';
    }

    if ($type eq 'misc_feature' and $name->[1] =~ /similar/i) {
      $type = 'computed_feature_by_similarity';
    } elsif ($type eq 'misc_feature') {
      warn "skipping a misc_feature\n";
      next;
    }

    my $parttype =  $feat->primary_tag eq 'mRNA'   ? 'exon' : $feat->primary_tag;

    if ($type eq 'gene') {
      $transcript_version = 0;
      $mRNA_version       = 0;
    } elsif ($type eq 'mRNA') {
      $name->[1] = sprintf("%s.t%02d",$name->[1],++$transcript_version);
    } elsif ($type eq 'CDS') {
      $name->[0] = 'mRNA';
      $name->[1] = sprintf("%s.t%02d",$name->[1],$transcript_version);
    }

    my $strand = $feat->strand;
    my $str    = defined $strand ?
                                     ($strand > 0 ? '+' : '-')
				   : '.';
    $self->load_gff_line( {
			   ref    => $acc,
			   class  => $refclass,
			   source => $source,
			   method => $type,
			   start  => $location->start,
			   stop   => $location->end,
			   score  => $feat->score || undef,
			   strand => $str,
			   phase  => $feat->frame || '.',

Bio/DB/GFF/Adaptor/biofetch.pm  view on Meta::CPAN

			   tstart => undef,
			   tstop  => undef,
			   attributes  => $attributes,
			  }
			) if ($type &&
                           ($type ne 'CDS'||($type eq 'CDS'&&@segments==1) ) );

    @$attributes = ();

    next if @segments == 1;
    for my $segment (@segments) {

      my $strand = $feat->strand;
      my $str    = defined $strand ?
                                     ($strand > 0 ? '+' : '-')
				   : '.';
      $self->load_gff_line( {
			     ref    => $segment->[2] eq $locus ? $acc : $segment->[2],
			     class  => $refclass,
			     source => $source,
			     method => $parttype,
			     start  => $segment->[0],
			     stop   => $segment->[1],
			     score  => $feat->score || undef,
			     strand => $str,
			     phase  => $feat->frame || '.',
			     gclass => $name->[0],
			     gname  => $name->[1],
			     tstart => undef,
			     tstop  => undef,
			     attributes  => $attributes,
			    }
			  );
    }

  }

  # finish loading
  $self->finish_load();

  # now load the DNA
  $self->load_sequence_string($acc,$seq->seq);

  1;
}

sub get_attributes {
  my $self = shift;
  my $seq  = shift;

  my @tags = $seq->all_tags or return;
  my @result;
  foreach my $tag (@tags) {
    foreach my $value ($seq->each_tag_value($tag)) {
      push @result,[$tag=>$value];
    }
  }
  \@result;
}

sub guess_name {
  my $self = shift;
  my $attributes = shift;
# remove this fix when Lincoln fixes it properly
  return ["Misc" => "Misc"] unless ($attributes);  # these are arbitrary, and possibly destructive defaults
  my @ordered_attributes = sort {($self->_preferred_tags->{$a->[0]} || 0) <=> ($self->_preferred_tags->{$b->[0]} || 0)} @$attributes;
  my $best = pop @ordered_attributes;
  @$attributes = @ordered_attributes;
  return $best;
}


sub _preferred_tags {
  my $self = shift;
  $self->{preferred_tags} = shift if @_;
  return $self->{preferred_tags};
}

sub _source {
  my $self = shift;
  $self->{source} = shift if @_;
  $self->{source};
}

1;