Bio::PopGen::IO::prettybase - Extract individual allele data from PrettyBase format

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

  https://redmine.open-bio.org/projects/bioperl/

 Title   : new
 Usage   : my $obj = Bio::PopGen::IO::prettybase->new();
 Function: Builds a new Bio::PopGen::IO::prettybase object 
 Returns : an instance of Bio::PopGen::IO::prettybase
 Args    : -field_delimiter      => a field delimiter character or regexp (default is /\t/ ) 
           -header               => boolean if the file will have a header and parser should
                                    skip first line in the file (default is false)
           -convert_indel_states => convert alleles which are longer than one character
                                    to an 'I' meaning insert state, and alleles which are
                                    '-' to a delete state.
                                    (default is false)

 Title   : flag
 Usage   : $obj->flag($flagname,$newval)
 Function: Get/Set the flag value
 Returns : value of a flag (a boolean)
 Args    : A flag name, currently we expect 
           'header', 'field_delimiter', or 'allele_delimiter' 
           on set, new value (a boolean or undef, optional)

 Title   : next_individual
 Usage   : my $ind = $popgenio->next_individual;
 Function: Retrieve the next individual from a dataset
 Returns : Bio::PopGen::IndividualI object
 Args    : none

 Title   : next_population
 Usage   : my $ind = $popgenio->next_population;
 Function: Retrieve the next population from a dataset
 Returns : Bio::PopGen::PopulationI object
 Args    : none
 Note    : Many implementation will not implement this

 Title   : write_individual
 Usage   : $popgenio->write_individual($ind);
 Function: Write an individual out in the file format
 Returns : none
 Args    : L<Bio::PopGen::PopulationI> object(s)

 Title   : write_population
 Usage   : $popgenio->write_population($pop);
 Function: Write a population out in the file format
 Returns : none
 Args    : L<Bio::PopGen::PopulationI> object(s)
 Note    : Many implementation will not implement this

#
# BioPerl module for Bio::PopGen::IO::prettybase
#
# Please direct questions and support issues to <bioperl-l@bioperl.org> 
#
# Cared for by Jason Stajich <jason-at-bioperl.org>
#
# Copyright Jason Stajich
#
# You may distribute this module under the same terms as perl itself

# POD documentation - main docs before the code

# Let the code begin...


package Bio::PopGen::IO::prettybase;
use vars qw($FieldDelim $Header);
use strict;

($FieldDelim,$Header) =( '\t',0);


use Bio::PopGen::Individual;
use Bio::PopGen::Population;
use Bio::PopGen::Genotype;

use base qw(Bio::PopGen::IO);

sub _initialize {
    my($self, @args) = @_;
    my ($fieldsep,
	$conv_indels,
	$header) = $self->_rearrange([qw(FIELD_DELIMITER
					 CONVERT_INDEL_STATES
					 HEADER)],@args);

    $self->flag('header', defined $header ? $header : $Header);
    $self->flag('field_delimiter',defined $fieldsep ? $fieldsep : $FieldDelim);
    $self->{'_header'} = undef;
    $self->{'_parsed_individiuals'} = [];
    $self->{'_parsed'} = 0;
    $self->flag('convert_indel',$conv_indels || 0);
    return 1;
}

sub flag{
    my $self = shift;
    my $fieldname = shift;
    return unless defined $fieldname;
    
    return $self->{'_flag'}->{$fieldname} = shift if @_;
    return $self->{'_flag'}->{$fieldname};
}

sub next_individual {
    my ($self) = @_;
    unless( $self->{'_parsed'} ) {
	$self->_parse_prettybase;
    }
    return $self->{'_parsed_individiuals'}->[$self->{'_iterator'}++];
}

# Plan is to just return the whole dataset as a single population by 
# default I think - people would then have each population in a separate
# file.

sub next_population{
    my ($self) = @_;
    my @inds;
    while( my $ind = $self->next_individual ) {
	push @inds, $ind;
    }
    return unless @inds;
    Bio::PopGen::Population->new(-individuals => \@inds);
}


sub _parse_prettybase {
    my $self = shift;
    my %inds;
    my $convert_indels = $self->flag('convert_indel');
    while( defined( $_ = $self->_readline) ) {
	next if( /^\s*\#/ || /^\s+$/ || ! length($_) );
	
	my ($site,$sample,@alleles) = split($self->flag('field_delimiter'),$_);
	if( ! defined $sample ) { 
	    warn("sample id is undefined for $_");
	    next;
	}
	for my $allele ( @alleles ) {
	    $allele =~ s/^\s+//;
	    $allele =~ s/\s+$//;
	    if( $convert_indels ) {
		if( length($allele) > 1 ) {
		    # we have an insert state
		    $allele = 'I';
		} elsif( $allele eq '-' ) {
		    # have a delete state
		    $allele = 'D';
		}
	    }
	}
	
	my $g = Bio::PopGen::Genotype->new(-alleles      => \@alleles,
					  -marker_name  => $site,
					  -individual_id=> $sample); 
	

	if( ! defined $inds{$sample} ) {
	    $inds{$sample} = Bio::PopGen::Individual->new(-unique_id => $sample);
	}
	$inds{$sample}->add_Genotype($g);
    }
    $self->{'_parsed_individiuals'} = [ values %inds ];
    $self->{'_parsed'} = 1;
    return;
}

sub write_individual{
    my ($self,@inds) = @_;
    foreach my $ind ( @inds ) {
	if (! ref($ind) || ! $ind->isa('Bio::PopGen::IndividualI') ) {
	    $self->warn("Cannot write an object that is not a Bio::PopGen::IndividualI object");
	    next;
	}
	foreach my $marker ( $ind->get_marker_names ) { 
	    my $g = $ind->get_Genotypes(-marker=> $marker);
	    next unless defined $g;
	    $self->_print( join("\t", $marker, $ind->unique_id, 
				$g->get_Alleles), "\n");	    
	}
    }
    
}

sub write_population{
    my ($self,@pops) = @_;
    foreach my $pop ( @pops ) {
	if (! ref($pop) || ! $pop->isa('Bio::PopGen::PopulationI') ) {
	    $self->warn("Cannot write an object that is not a Bio::PopGen::PopulationI object");
	    next;
	}
	my @mnames = $pop->get_marker_names;
	foreach my $ind ( $pop->get_Individuals ) {
	    if (! ref($ind) || ! $ind->isa('Bio::PopGen::IndividualI') ) {
		$self->warn("Cannot write an object that is not a Bio::PopGen::IndividualI object");
		next;
	    }
	    foreach my $marker ( @mnames ) { 
		my $g = $ind->get_Genotypes(-marker=> $marker);
		next unless defined $g;
		$self->_print( join("\t", $marker, $ind->unique_id, 
				    $g->get_Alleles), "\n");
			   
	    }
	}
    }
}

1;