#
# Perl Module for GeneFeature
#
# Cared for by Tim Hubbard <th@sanger.ac.uk>
#
# Copyright Genome Research Limited (1997). Please see information on licensing in LICENSE

package GeneFeature;

use vars qw($AUTOLOAD @ISA @EXPORT_OK);
use Exporter;
use Carp;
use strict;
use GeneFeaturePair;

#
# Place functions/variables you want to *export*, ie be visible from the caller package into @EXPORT_OK
#

@EXPORT_OK = qw();

#
# @ISA has our inheritance.
#

@ISA = ( 'Exporter' );


my %fields = (
	      seqname => undef, 
	      source  => undef,
	      feature  => undef,
	      start => undef,
	      end => undef,
	      score => undef,
	      strand => undef,
	      frame => undef,
	      group => undef,
	      pairs => undef,
	      member => undef,
);

sub new {
    my $ref = shift;
    my $class = ref($ref) || $ref;
    
    my $self = {
	'_permitted' => \%fields,
	%fields, };
    $self->{'pairs'} = []; # makes pairs an anonymous array.
    $self->{'member'} = {}; # makes member an anonymous array.

    bless $self, $class;
    return $self;
}

#
# Autoload up my field name set/get
#
sub AUTOLOAD {
    my $self = shift;
    my $type = ref($self) || carp "Ok, $self is not an object of mine!";
    my $name = $AUTOLOAD;

    # don't propagate DESTROY messages...

    $name =~ /::DESTROY/ && return;

    $name =~ s/.*://; #get only the bit we want
    unless (exists $self->{'_permitted'}->{$name} ) {
	carp "In type $type, can't access $name - probably passed a wrong variable into Sequence  ";
    }
    if (@_) {
	return $self->{$name} = shift;
    } else {
	return $self->{$name}
    }
}

#
# Method to parse a tab delimited line into a GeneFeature object
#

sub new_from_line {
    my $string = shift;
    my $self;
    my @array;

    chomp($string);
    $self = new GeneFeature;

    @array = split(/\t/,$string);

    $self->seqname(shift(@array));
    $self->source(shift(@array));
    $self->feature(shift(@array));
    $self->start(shift(@array));
    $self->end(shift(@array));
    $self->score(shift(@array));
    $self->strand(shift(@array));    
    $self->frame(shift(@array));
    $self->group(shift(@array));
    
    return $self;
}

#
# Method to return a formatted output of a GeneFeature object to a filehandle.
# Uses dump_string
#

sub dump {
    my $self = shift;
    my $file = shift;
    my $tab = shift;
    
    if( !defined $file ){
	$file = \*STDOUT;
    }

    print $file $self->dump_string($tab)."\n";
}

#
# Method to return a formatted output of a GeneFeature object to a string
#

sub dump_string {
    my $self = shift;
    my $tab = shift;

    if($tab){
	sprintf("%s\t%s\t%s\t%d\t%d\t%f\t%s\t%s\t%s",
		$self->seqname(),
		$self->source(),
		$self->feature(),
		$self->start(),
		$self->end(),
		$self->score(),
		$self->strand(),
		$self->frame(),
		$self->group());
    }else{
	sprintf("%s %s %s %d %d %f %s %s %s",
		$self->seqname(),
		$self->source(),
		$self->feature(),
		$self->start(),
		$self->end(),
		$self->score(),
		$self->strand(),
		$self->frame(),
		$self->group());
    }
}

#
# Method to return a formatted output of a GeneFeature object to a filehandle.
# Uses dump_string.  Includes information about any pairing.
#

sub dump_pair {
    my $self = shift;
    my $file = shift;
    my $tab = shift;
    
    my($out,$other);
    
    if( !defined $file ){
	$file = \*STDOUT;
    }

# check for listed pair
    my($ngfp,$gfp)=$self->getPair();

# get ref to genefinder object paired with self
    if($ngfp!=0){
	$other=$gfp->other($self);

	if($tab){
	    $out = sprintf("\t%s\t%d\t%d\t%d\t%d",
			   $other->group(),
			   $other->start(),
			   $other->end(),
			   $gfp->e5(),
			   $gfp->e3(),
			   );
	}else{
	    $out = sprintf(" %s %d %d %d %d",
			   $other->group(),
			   $other->start(),
			   $other->end(),
			   $gfp->e5(),
			   $gfp->e3(),
			   );
	}
    }else{
	if($tab){
	    $out = "\t.\t0\t0\t0\t0";
	}else{
	    $out = " . 0 0 0 0";
	}
    }

    print $file $self->dump_string($tab).$out."\n";
}

#
# Method to compare two GeneFeature objects to look for a match
# returns 5 scalars as an array
# 0: 0 or 1 indicating if objects match by criteria supplied
# 1: number indicating signed difference in 5' end of 2 objects
# 2: number indicating signed difference in 3' end of 2 objects
# 3: 0      if no overlap
#    1      if match
#    2      if overlap, but rejected on tolerance+single
#    3      if overlap, but rejected on strand
# 4: string if overlap
#

sub match {
    my $self = shift;
    my $other = shift;
    my $tolerance = shift;
    my $single = shift;
    my $strand = shift;

    my($a1s,$a1e,$a2s,$a2e,$maxs,$mine,$f3,$f5,$match,$string,$type,
       $len,$slen);

    $a1s=$self->start;
    $a1e=$self->end;
    $a2s=$other->start;
    $a2e=$other->end;
    $maxs=&max($a1s,$a2s);
    $mine=&min($a1e,$a2e);
#    print "$a1s,$a2s,$a1e,$a2e,$maxs,$mine\n";
    if($maxs<=$mine){

# define string
	$len=$mine-$maxs+1;
	$slen=&min($a1e-$a1s,$a2e-$a2s)+1;
	$string=$len.'/'.$slen.' '.$self->group.": $a1s-$a1e <=> $a2s-$a2e :".$other->group;
#	print "$string\n";

# reject on strand early
	if($strand && 
	   ($self->strand ne $other->strand)){
	    $type=3;
	    return 0,0,0,$type,$string;
	}
	
# +ve prediction late, -ve prediction early
	if($self->strand eq '+'){
	    $f5=$a1s-$a2s;
	    $f3=$a1e-$a2e;
	}else{
	    $f3=$a2s-$a1s;
	    $f5=$a2e-$a1e;
	}

# test overlap for 'match' criteria
	if($tolerance<0 ||
	   (abs($f3)<=$tolerance && abs($f5)<=$tolerance) ||
	   ($single && 
	    (abs($f3)<=$tolerance || abs($f5)<=$tolerance))){
	    $match=1;
	    $type=1;
	}else{
	    $match=0;
	    $type=2;
	}

	$match,$f5,$f3,$type,$string;

    }else{
	0,0,0,0;
    }
}

#
# Method that uses overlap method to return a simple y/n answer on there being an 'overlap'
# if verbose=1, returns overlap string if there's a match
#

sub overlap_logical {
    my $self = shift;
    my $other = shift;
    my $verbose = shift;

    my $tolerance = -1;
    my $single = 0;
    my $strand = 0;
    my @ret=$self->match($other,$tolerance,$single,$strand);
#    print "$ret[0],$ret[1],$ret[2],$ret[3]\n";
    if($verbose && $ret[0]){
	return $ret[4];
    }else{
	return $ret[0];
    }
}

#
# Method that uses overlap method to return a simple y/n answer on there being an exact match
# if verbose=1, returns overlap string if there's a match
#

sub match_logical {
    my $self = shift;
    my $other = shift;
    my $verbose = shift;

    my $tolerance = 0;
    my $single = 0;
    my $strand = 1;
    my @ret=$self->match($other,$tolerance,$single,$strand);
    if($verbose && $ret[0]){
	return $ret[4];
    }else{
	return $ret[0];
    }
}

#
# Method to add a reference to a GeneFeaturePair object
#

sub addPair {
    my $self = shift;
    my $gfp = shift;
    push(@{$self->{'pairs'}}, $gfp);
}

#
# Method to get reference to a GeneFeaturePair object
# Returns number of GeneFeaturePair objects followed by object selected
#

sub getPair {
    my $self = shift;
    my $index = shift;

    my $ngfp = scalar(@{$self->{'pairs'}});
    if($ngfp==0){
	0;
    }else{
	if($ngfp<$index){
	    $index=$ngfp;
	}
	$ngfp,${$self->{'pairs'}}[$ngfp-1];
    }
}

#
# Method to get reference to a GeneFeaturePair object
# Returns number of GeneFeaturePair objects followed by object selected
#

sub getPairs {
    my $self = shift;
    @{$self->{'pairs'}};
}

#
# Method to return true or false on if GeneFeature is paired or not
#

sub getPair_logical {
    my $self = shift;
    my @temp;
    @temp=$self->getPair();
    $temp[0];
}

#
# Method to add a member record to indicate the parent GFF object
# for this particular grouping of GeneFeatures
#

sub addMember {
    my $self = shift;
    my $parent = shift;
    my $membergroup = shift;
    ${$self->{'member'}}{$membergroup}=$parent;
}

#
# Method to get reference to parent GFF object of GeneFeature object
# under this particular grouping
#

sub getMember {
    my $self = shift;
    my $membergroup = shift;
    my ($gff);
    $gff=$self->{'member'}->{$membergroup};
}


# misc subroutines:

# max:
# D: return max of i and j
sub max{
    my($i,$j)=@_;
    if($i>$j){
	$i;
    }else{
	$j;
    }
}

# min:
# D: return min of i and j
sub min{
    my($i,$j)=@_;
    if($i<$j){
	$i;
    }else{
	$j;
    }
}


1;  # says use was ok
__END__

=head1 NAME

GeneFeature

=head1 DESCRIPTION

Description for B<GeneFeature>

=head1 AUTHOR

B<Tim Hubbard> Email th@sanger.ac.uk

=head1 Functions

=over 5

=item new_from_line

Method to parse a tab delimited line into a GeneFeature object

=item dump

Method to return a formatted output of a GeneFeature object to a
filehandle.  Uses dump_string

=item dump_string

Method to return a formatted output of a GeneFeature object to a
string.

=item dump_pair

Method to return a formatted output of a GeneFeature object to a
filehandle.  Uses dump_string.  Includes information about any
pairing.

=item match

Method to compare two GeneFeature objects to look for an overlap
returns 5 scalars as an array

=over 5

=item 1

0 or 1 indicating if objects match by criteria supplied

=item 2

number indicating signed difference in 5' end of 2 objects

=item 3

number indicating signed difference in 3' end of 2 objects

=item 4

0 if no overlap; 
1 if match;
2 if overlap, but rejected on tolerance+single;
3 if overlap, but rejected on strand;

=item 5

descriptive string about overlap, if there is one

=back

=item overlap_logical

Method that uses overlap method to return a simple y/n answer on there
being an 'overlap'

=item addPair

Method to add a reference to a GeneFeaturePair object

=item getPair

Method to get reference to a GeneFeaturePair object.  Returns number
of GeneFeaturePair objects followed by object selected

=item getPair_logical

No current documentation
