view release on metacpan or  search on metacpan

Bio/AlignIO.pm  view on Meta::CPAN

=head1 AUTHOR - Peter Schattner

Email: schattner@alum.mit.edu

=head1 CONTRIBUTORS

Jason Stajich, jason@bioperl.org

=head1 APPENDIX

The rest of the documentation details each of the object
methods. Internal methods are usually preceded with a _

=cut

# 'Let the code begin...

package Bio::AlignIO;

use strict;

use Bio::Seq;
use Bio::LocatableSeq;
use Bio::SimpleAlign;
use Bio::Tools::GuessSeqFormat;
use base qw(Bio::Root::Root Bio::Root::IO);

=head2 new

 Title   : new
 Usage   : $stream = Bio::AlignIO->new(-file => $filename,
                                       -format => 'Format')
 Function: Returns a new seqstream
 Returns : A Bio::AlignIO::Handler initialised with
           the appropriate format
 Args    : -file => $filename
           -format => format
           -fh => filehandle to attach to
           -displayname_flat => 1 [optional]
                                to force the displayname to not show start/end
                                information

=cut

sub new {
    my ($caller,@args) = @_;
    my $class = ref($caller) || $caller;

    # or do we want to call SUPER on an object if $caller is an
    # object?
    if( $class =~ /Bio::AlignIO::(\S+)/ ) {
	my ($self) = $class->SUPER::new(@args);
	$self->_initialize(@args);
	return $self;
    } else {

	my %param = @args;
	@param{ map { lc $_ } keys %param } = values %param; # lowercase keys
	my $format = $param{'-format'} ||
	    $class->_guess_format( $param{-file} || $ARGV[0] );
        unless ($format) {
            if ($param{-file}) {
                $format = Bio::Tools::GuessSeqFormat->new(-file => $param{-file}||$ARGV[0] )->guess;
            }
            elsif ($param{-fh}) {
                $format = Bio::Tools::GuessSeqFormat->new(-fh => $param{-fh}||$ARGV[0] )->guess;
            }
        }
	$format = "\L$format";	# normalize capitalization to lower case
        $class->throw("Unknown format given or could not determine it [$format]")
            unless $format;

	return unless( $class->_load_format_module($format) );
	return "Bio::AlignIO::$format"->new(@args);
    }
}


=head2 newFh

 Title   : newFh
 Usage   : $fh = Bio::AlignIO->newFh(-file=>$filename,-format=>'Format')
 Function: does a new() followed by an fh()
 Example : $fh = Bio::AlignIO->newFh(-file=>$filename,-format=>'Format')
           $sequence = <$fh>;   # read a sequence object
           print $fh $sequence; # write a sequence object
 Returns : filehandle tied to the Bio::AlignIO::Fh class
 Args    :

=cut

sub newFh {
  my $class = shift;
  return unless my $self = $class->new(@_);
  return $self->fh;
}

=head2 fh

 Title   : fh
 Usage   : $obj->fh
 Function:
 Example : $fh = $obj->fh;      # make a tied filehandle
           $sequence = <$fh>;   # read a sequence object
           print $fh $sequence; # write a sequence object
 Returns : filehandle tied to the Bio::AlignIO::Fh class
 Args    :

=cut


sub fh {
  my $self = shift;
  my $class = ref($self) || $self;
  my $s = Symbol::gensym;
  tie $$s,$class,$self;
  return $s;
}


=head2 format

 Title   : format
 Usage   : $format = $stream->format()
 Function: Get the alignment format
 Returns : alignment format

Bio/AlignIO.pm  view on Meta::CPAN

 Title   : _load_format_module
 Usage   : *INTERNAL AlignIO stuff*
 Function: Loads up (like use) a module at run time on demand
 Example :
 Returns :
 Args    :

=cut

sub _load_format_module {
  my ($self,$format) = @_;
  my $module = "Bio::AlignIO::" . $format;
  my $ok;

  eval {
      $ok = $self->_load_module($module);
  };
  if ( $@ ) {
    print STDERR <<END;
$self: $format cannot be found
Exception $@
For more information about the AlignIO system please see the AlignIO docs.
This includes ways of checking for formats at compile time, not run time
END
  ;
    return;
  }
  return 1;
}

=head2 next_aln

 Title   : next_aln
 Usage   : $aln = stream->next_aln
 Function: reads the next $aln object from the stream
 Returns : a Bio::Align::AlignI compliant object
 Args    :

=cut

sub next_aln {
   my ($self,$aln) = @_;
   $self->throw("Sorry, you cannot read from a generic Bio::AlignIO object.");
}

=head2 write_aln

 Title   : write_aln
 Usage   : $stream->write_aln($aln)
 Function: writes the $aln object into the stream
 Returns : 1 for success and 0 for error
 Args    : Bio::Seq object

=cut

sub write_aln {
    my ($self,$aln) = @_;
    $self->throw("Sorry, you cannot write to a generic Bio::AlignIO object.");
}

=head2 _guess_format

 Title   : _guess_format
 Usage   : $obj->_guess_format($filename)
 Function:
 Example :
 Returns : guessed format of filename (lower case)
 Args    :

=cut

sub _guess_format {
my $class = shift;
   return unless $_ = shift;
   return 'clustalw'    if /\.aln$/i;
   return 'emboss'      if /\.(water|needle)$/i;
   return 'metafasta'   if /\.metafasta$/;
   return 'fasta'       if /\.(fasta|fast|seq|fa|fsa|nt|aa)$/i;
   return 'maf'         if /\.maf/i;
   return 'mega'        if /\.(meg|mega)$/i;
   return 'meme'        if /\.meme$/i;
   return 'msf'         if /\.(msf|pileup|gcg)$/i;
   return 'nexus'       if /\.(nexus|nex)$/i;
   return 'pfam'        if /\.(pfam|pfm)$/i;
   return 'phylip'      if /\.(phylip|phlp|phyl|phy|ph)$/i;
   return 'psi'         if /\.psi$/i;
   return 'stockholm'   if /\.stk$/i;
   return 'selex'       if /\.(selex|slx|selx|slex|sx)$/i;
   return 'xmfa'        if /\.xmfa$/i;
}

sub DESTROY {
    my $self = shift;
    $self->close();
}

sub TIEHANDLE {
  my $class = shift;
  return bless {'alignio' => shift},$class;
}

sub READLINE {
  my $self = shift;
  return $self->{'alignio'}->next_aln() || undef unless wantarray;
  my (@list,$obj);
  push @list,$obj  while $obj = $self->{'alignio'}->next_aln();
  return @list;
}

sub PRINT {
  my $self = shift;
  $self->{'alignio'}->write_aln(@_);
}


=head2 force_displayname_flat

 Title   : force_displayname_flat
 Usage   : $obj->force_displayname_flat($newval)
 Function:
 Example :
 Returns : value of force_displayname_flat (a scalar)
 Args    : on set, new value (a scalar or undef, optional)


=cut

sub force_displayname_flat{
    my $self = shift;
    return $self->{'_force_displayname_flat'} = shift if @_;
    return $self->{'_force_displayname_flat'} || 0;
}