# $Id: MapTiling.pm 16123 2009-09-17 12:57:27Z cjfields $
#
# BioPerl module for Bio::Search::Tiling::MapTiling
#
# Please direct questions and support issues to <bioperl-l@bioperl.org>
#
# Cared for by Mark A. Jensen <maj@fortinbras.us>
#
# Copyright Mark A. Jensen
#
# You may distribute this module under the same terms as perl itself

# POD documentation - main docs before the code

=head1 NAME

Bio::Search::Tiling::MapTiling - An implementation of an HSP tiling
algorithm, with methods to obtain frequently-requested statistics

=head1 SYNOPSIS

 # get a BLAST $hit from somewhere, then
 $tiling = Bio::Search::Tiling::MapTiling->new($hit);

 # stats
 $numID = $tiling->identities();
 $numCons = $tiling->conserved();
 $query_length = $tiling->length('query');
 $subject_length = $tiling->length('subject'); # or...
 $subject_length = $tiling->length('hit');

 # get a visual on the coverage map
 print $tiling->coverage_map_as_text('query',$context,'LEGEND');

 # tilings
 $context = $tiling->_context( -type => 'subject', -strand=> 1, -frame=>1);
 @covering_hsps_for_subject = $tiling->next_tiling('subject',$context);
 $context = $tiling->_context( -type => 'query', -strand=> -1, -frame=>0);
 @covering_hsps_for_query   = $tiling->next_tiling('query', $context);

=head1 DESCRIPTION

Frequently, users want to use a set of high-scoring pairs (HSPs)
obtained from a BLAST or other search to assess the overall level of
identity, conservation, or coverage represented by matches between a
subject and a query sequence. Because a set of HSPs frequently
describes multiple overlapping sequence fragments, a simple summation of
statistics over the HSPs will generally overestimate those
statistics. To obtain an accurate estimate of global hit statistics, a
'tiling' of HSPs onto either the subject or the query sequence must be
performed, in order to properly correct for this. 

This module will execute a tiling algorithm on a given hit based on an
interval decomposition I'm calling the "coverage map". Internal object
methods compute the various statistics, which are then stored in
appropriately-named public object attributes. See
L<Bio::Search::Tiling::MapTileUtils> for more info on the algorithm. 

=head2 STRAND/FRAME CONTEXTS

In BLASTX, TBLASTN, and TBLASTX reports, strand and frame information
are reported for the query, subject, or query and subject,
respectively, for each HSP. Tilings for these sequence types are only
meaningful when they include HSPs in the same strand and frame, or 
"context". So, in these situations, the context must be specified
in the method calls or the methods will throw. 

Contexts are specified as strings: C<[ 'all' | [m|p][_|0|1|2] ]>, where
C<all> = all HSPs (will throw if context must be specified), C<m> = minus
strand, C<p> = plus strand, and C<_> = no frame info, C<0,1,2> = respective
(absolute) frame. The L</_make_context_key> method will convert a (strand,
frame) specification to a context string, e.g.:

    $context = $self->_context(-type=>'query', -strand=>-1, -frame=>-2);

returns C<m2>.

The contexts present among the HSPs in a hit are identified and stored
for convenience upon object construction. These are accessed off the
object with the L</contexts> method. If contexts don't apply for the
given report, this returns C<('all')>. 

=head1 DESIGN NOTE

The major calculations are made just-in-time, and then memoized. So,
for example, for a given MapTiling object, a coverage map would
usually be calculated only once (for the query), and at most twice (if
the subject perspective is also desired), and then only when a
statistic is first accessed. Afterward, the map and/or any statistic
is read from storage. So feel free to call the statistic methods
frequently if it suits you.

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

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

=head2 Support

Please direct usage questions or support issues to the mailing list:

I<bioperl-l@bioperl.org>

rather than to the module maintainer directly. Many experienced and
reponsive experts will be able look at the problem and quickly
address it. Please include a thorough description of the problem
with code and data examples if at all possible.

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via
the web:

  http://bugzilla.open-bio.org/

=head1 AUTHOR - Mark A. Jensen

Email maj -at- fortinbras -dot- us

=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::Search::Tiling::MapTiling;
use strict;
use warnings;

# Object preamble - inherits from Bio::Root::Root
#use lib '../../..';

use Bio::Root::Root;
use Bio::Search::Tiling::TilingI;
use Bio::Search::Tiling::MapTileUtils;

# use base qw(Bio::Root::Root Bio::Search::Tiling::TilingI);
use base qw(Bio::Root::Root Bio::Search::Tiling::TilingI);

=head1 CONSTRUCTOR

=head2 new

 Title   : new
 Usage   : my $obj = new Bio::Search::Tiling::GenericTiling();
 Function: Builds a new Bio::Search::Tiling::GenericTiling object 
 Returns : an instance of Bio::Search::Tiling::GenericTiling
 Args    : -hit    => $a_Bio_Search_Hit_HitI_object
           general filter function:
           -hsp_filter => sub { my $this_hsp = shift; 
                                ...;
                                return 1 if $wanted;
                                return 0; }

=cut

sub new {
    my $class = shift;
    my @args = @_;
    my $self = $class->SUPER::new(@args);
    my($hit, $filter) = $self->_rearrange( [qw( HIT HSP_FILTER)],@args );

    $self->throw("HitI object required") unless $hit;
    $self->throw("Argument must be HitI object") unless ( ref $hit && $hit->isa('Bio::Search::Hit::HitI') );
    $self->{hit} = $hit;
    $self->_set_attributes();
    $self->{"_algorithm"} = $hit->algorithm;

    my @hsps = $hit->hsps;
    # apply filter function if requested
    if ( defined $filter ) {
	if ( ref($filter) eq 'CODE' ) {
	    @hsps = map { $filter->($_) ? $_ : () } @hsps;
	}
	else {
	    $self->warn("-filter is not a coderef; ignoring");
	}
    }
    
    # identify available contexts
    for my $t qw( query hit ) {
	my %contexts;
	for my $i (0..$#hsps) {
	    my $ctxt = $self->_context(
		-type => $t,
		-strand => $hsps[$i]->strand($t),
		-frame  => $hsps[$i]->frame($t));
	    $contexts{$ctxt} ||= [];
	    push @{$contexts{$ctxt}}, $i;
	}
	$self->{"_contexts_${t}"} = \%contexts;
    }

    $self->warn("No HSPs present in hit after filtering") unless (@hsps);
    $self->hsps(\@hsps);
    return $self;
}

# a tiling is based on the set of hsps contained in a single hit.
# check all the boundaries - zero hsps, one hsp, all disjoint hsps

=head1 TILING ITERATORS

=head2 next_tiling

 Title   : next_tiling
 Usage   : @hsps = $self->next_tiling($type);
 Function: Obtain a tiling: a minimal set of HSPs covering the $type
           ('hit', 'subject', 'query') sequence
 Example :
 Returns : an array of HSPI objects
 Args    : scalar $type: one of 'hit', 'subject', 'query', with
           'subject' an alias for 'hit'

=cut

sub next_tiling{
    my $self = shift;
    my ($type, $context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_context_arg($type, \$context);
    return $self->_tiling_iterator($type, $context)->();
}

=head2 rewind_tilings

 Title   : rewind_tilings
 Usage   : $self->rewind_tilings($type)
 Function: Reset the next_tilings($type) iterator
 Example :
 Returns : True on success
 Args    : scalar $type: one of 'hit', 'subject', 'query';
           default is 'query'

=cut

sub rewind_tilings{
    my $self = shift;
    my ($type,$context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_context_arg($type, \$context);
    return $self->_tiling_iterator($type, $context)->('REWIND');
}

=head1 STATISTICS

=head2 identities

 Title   : identities
 Usage   : $tiling->identities($type, $action, $context)
 Function: Retrieve the calculated number of identities for the invocant
 Example : 
 Returns : value of identities (a scalar)
 Args    : scalar $type: one of 'hit', 'subject', 'query'
           default is 'query'
           option scalar $action: one of 'exact', 'est', 'fast', 'max'
           default is 'exact'
           option scalar $context: strand/frame context string
 Note    : getter only

=cut

sub identities{
    my $self = shift;
    my ($type, $action, $context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_action_arg(\$action);
    $self->_check_context_arg($type, \$context);
    if (!defined $self->{"identities_${type}_${action}_${context}"}) {
	$self->_calc_stats($type, $action, $context);
    }
    return $self->{"identities_${type}_${action}_${context}"};
}

=head2 conserved

 Title   : conserved
 Usage   : $tiling->conserved($type, $action)
 Function: Retrieve the calculated number of conserved sites for the invocant
 Example : 
 Returns : value of conserved (a scalar)
 Args    : scalar $type: one of 'hit', 'subject', 'query'
           default is 'query'
           option scalar $action: one of 'exact', 'est', 'fast', 'max'
           default is 'exact'
           option scalar $context: strand/frame context string
 Note    : getter only 

=cut

sub conserved{
    my $self = shift;
    my ($type, $action, $context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_action_arg(\$action);
    $self->_check_context_arg($type, \$context);
    if (!defined $self->{"conserved_${type}_${action}_${context}"}) {
	$self->_calc_stats($type, $action, $context);
    }
    return $self->{"conserved_${type}_${action}_${context}"};
}

=head2 length

 Title   : length
 Usage   : $tiling->length($type, $action, $context)
 Function: Retrieve the total length of aligned residues for 
           the seq $type
 Example : 
 Returns : value of length (a scalar)
 Args    : scalar $type: one of 'hit', 'subject', 'query'
           default is 'query'
           option scalar $action: one of 'exact', 'est', 'fast', 'max'
           default is 'exact'
           option scalar $context: strand/frame context string
 Note    : getter only 

=cut

sub length{
    my $self = shift;
    my ($type,$action,$context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_action_arg(\$action);
    $self->_check_context_arg($type, \$context);
    if (!defined $self->{"length_${type}_${action}_${context}"}) {
	$self->_calc_stats($type, $action, $context);
    }
    return $self->{"length_${type}_${action}_${context}"};
}

=head2 frac

 Title   : frac
 Usage   : $tiling->frac($type, $denom, $action, $context, $method)
 Function: Return the fraction of sequence length consisting
           of desired kinds of pairs (given by $method), 
           with respect to $denom
 Returns : scalar float
 Args    : -type => one of 'hit', 'subject', 'query'
           -denom => one of 'total', 'aligned'
           -action => one of 'exact', 'est', 'fast', 'max'
           -context => strand/frame context string
           -method => one of 'identical', 'conserved'
 Note    : $denom == 'aligned', return desired_stat/num_aligned
           $denom == 'total', return desired_stat/_reported_length
             (i.e., length of the original input sequences)
 Note    : In keeping with the spirit of Bio::Search::HSP::HSPI, 
           reported lengths of translated dna are reduced by 
           a factor of 3, to provide fractions relative to 
           amino acid coordinates. 

=cut

sub frac {
    my $self = shift;
    my @args = @_;
    my ($type, $denom, $action, $context, $method) = $self->_rearrange([qw(TYPE DENOM ACTION CONTEXT METHOD)],@args);
    $self->_check_type_arg(\$type);
    $self->_check_action_arg(\$action);
    $self->_check_context_arg($type, \$context);
    unless ($method and grep(/^$method$/, qw( identical conserved ))) {
	$self->throw("-method must specified; one of ('identical', 'conserved')");
    }
    $denom ||= 'total';
    unless (grep /^$denom/, qw( total aligned )) {
	$self->throw("Denominator selection must be one of ('total', 'aligned'), not '$denom'");
    }
    my $key = "frac_${method}_${type}_${denom}_${action}_${context}";
    my $stat;
    for ($method) {
	$_ eq 'identical' && do {
	    $stat = $self->identities($type, $action, $context);
	    last;
	};
	$_ eq 'conserved' && do {
	    $stat = $self->conserved($type, $action, $context);
	    last;
	};
	do {
	    $self->throw("What are YOU doing here?");
	};
    }
    if (!defined $self->{$key}) {
	for ($denom) {
	    /total/ && do {
		$self->{$key} =
		    $stat/$self->_reported_length($type); # need fudge fac??
		last;
	    };
	    /aligned/ && do {
		$self->{$key} =
		    $stat/$self->length($type,$action,$context);
		last;
	    };
	    do {
		$self->throw("What are YOU doing here?");
	    };
	}
    }
    return $self->{$key};
}

=head2 frac_identical

 Title   : frac_identical
 Usage   : $tiling->frac_identical($type, $denom, $action, $context)
 Function: Return the fraction of sequence length consisting
           of identical pairs, with respect to $denom
 Returns : scalar float
 Args    : -type => one of 'hit', 'subject', 'query'
           -denom => one of 'total', 'aligned'
           -action => one of 'exact', 'est', 'fast', 'max'
           -context => strand/frame context string
 Note    : $denom == 'aligned', return conserved/num_aligned
           $denom == 'total', return conserved/_reported_length
             (i.e., length of the original input sequences)
 Note    : In keeping with the spirit of Bio::Search::HSP::HSPI, 
           reported lengths of translated dna are reduced by 
           a factor of 3, to provide fractions relative to 
           amino acid coordinates. 
 Note    : This an alias that calls frac()

=cut

sub frac_identical{
    my $self = shift;
    my @args = @_;
    my ($type, $denom, $action,$context) = $self->_rearrange( [qw[ TYPE DENOM ACTION CONTEXT]],@args );
    $self->frac( -type=>$type, -denom=>$denom, -action=>$action, -method=>'identical', -context=>$context);
}

=head2 frac_conserved

 Title   : frac_conserved
 Usage   : $tiling->frac_conserved($type, $denom, $action, $context)
 Function: Return the fraction of sequence length consisting
           of conserved pairs, with respect to $denom
 Returns : scalar float
 Args    : -type => one of 'hit', 'subject', 'query'
           -denom => one of 'total', 'aligned'
           -action => one of 'exact', 'est', 'fast', 'max'
           -context => strand/frame context string
 Note    : $denom == 'aligned', return conserved/num_aligned
           $denom == 'total', return conserved/_reported_length
             (i.e., length of the original input sequences)
 Note    : In keeping with the spirit of Bio::Search::HSP::HSPI, 
           reported lengths of translated dna are reduced by 
           a factor of 3, to provide fractions relative to 
           amino acid coordinates. 
 Note    : This an alias that calls frac()

=cut

sub frac_conserved{
    my $self = shift;
    my @args = @_;
    my ($type, $denom, $action, $context) = $self->_rearrange( [qw[ TYPE DENOM ACTION CONTEXT]],@args );
    $self->frac( -type=>$type, -denom=>$denom, -action=>$action, -context=>$context, -method=>'conserved');
}

=head2 frac_aligned

 Title   : frac_aligned
 Aliases : frac_aligned_query - frac_aligned(-type=>'query',...)
           frac_aligned_hit   - frac_aligned(-type=>'hit',...)
 Usage   : $tiling->frac_aligned(-type=>$type,
                                 -action=>$action,
                                 -context=>$context)
 Function: Return the fraction of input sequence length
           that was aligned by the algorithm
 Returns : scalar float
 Args    : -type => one of 'hit', 'subject', 'query'
           -action => one of 'exact', 'est', 'fast', 'max'
           -context => strand/frame context string

=cut

sub frac_aligned{
    my ($self, @args) = @_;
    my ($type, $action, $context) = $self->_rearrange([qw(TYPE ACTION CONTEXT)],@args);
    $self->_check_type_arg(\$type);
    $self->_check_action_arg(\$action);
    $self->_check_context_arg($type, \$context);
    if (!$self->{"frac_aligned_${type}_${action}_${context}"}) {
	$self->{"frac_aligned_${type}_${action}_${context}"} = $self->num_aligned($type,$action,$context)/$self->_reported_length($type);
    }
    return $self->{"frac_aligned_${type}_${action}_${context}"};
}

sub frac_aligned_query { shift->frac_aligned(-type=>'query', @_) }
sub frac_aligned_hit { shift->frac_aligned(-type=>'hit', @_) }
    

=head2 num_aligned

 Title   : num_aligned
 Usage   : $tiling->num_aligned(-type=>$type)
 Function: Return the number of residues of sequence $type
           that were aligned by the algorithm
 Returns : scalar int
 Args    : -type => one of 'hit', 'subject', 'query'
           -action => one of 'exact', 'est', 'fast', 'max'
           -context => strand/frame context string
 Note    : Since this is calculated from reported coordinates,
           not symbol string counts, it is already in terms of
           "logical length"
 Note    : Aliases length()

=cut

sub num_aligned { shift->length( @_ ) };

=head2 num_unaligned

 Title   : num_unaligned
 Usage   : $tiling->num_unaligned(-type=>$type)
 Function: Return the number of residues of sequence $type
           that were left unaligned by the algorithm
 Returns : scalar int
 Args    : -type => one of 'hit', 'subject', 'query'
           -action => one of 'exact', 'est', 'fast', 'max'
           -context => strand/frame context string
 Note    : Since this is calculated from reported coordinates,
           not symbol string counts, it is already in terms of
           "logical length"

=cut

sub num_unaligned {
    my $self = shift;
    my ($type,$action,$context) = @_;
    my $ret;
    $self->_check_type_arg(\$type);
    $self->_check_action_arg(\$action);
    $self->_check_context_arg($type, \$context);
    if (!defined $self->{"num_unaligned_${type}_${action}_${context}"}) {
	$self->{"num_unaligned_${type}_${action}_${context}"} = $self->_reported_length($type)-$self->num_aligned($type,$action,$context);
    }
    return $self->{"num_unaligned_${type}_${action}_${context}"};
}
	

=head2 range

 Title   : range
 Usage   : $tiling->range(-type=>$type)
 Function: Returns the extent of the longest tiling
           as ($min_coord, $max_coord)
 Returns : array of two scalar integers
 Args    : -type => one of 'hit', 'subject', 'query'
           -context => strand/frame context string

=cut

sub range {
    my ($self, $type, $context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_context_arg($type, \$context);
    my @a = $self->_contig_intersection($type,$context);
    return ($a[0][0], $a[-1][1]);
}



=head1 ACCESSORS

=head2 coverage_map

 Title   : coverage_map
 Usage   : $map = $tiling->coverage_map($type)
 Function: Property to contain the coverage map calculated
           by _calc_coverage_map() - see that for 
           details
 Example : 
 Returns : value of coverage_map_$type as an array
 Args    : scalar $type: one of 'hit', 'subject', 'query'
           default is 'query'
 Note    : getter 

=cut

sub coverage_map{
    my $self = shift;
    my ($type, $context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_context_arg($type, \$context);

    if (!defined $self->{"coverage_map_${type}_${context}"}) {
	# following calculates coverage maps in all strands/frames
	# if necessary
	$self->_calc_coverage_map($type, $context);
    }
    # if undef is returned, then there were no hsps for given strand/frame
    if (!defined $self->{"coverage_map_${type}_${context}"}) {
	$self->warn("No HSPS present for type '$type' in context '$context' for this hit");
	return undef;
    }
    return @{$self->{"coverage_map_${type}_${context}"}};
}

=head2 coverage_map_as_text

 Title   : coverage_map_as_text
 Usage   : $tiling->coverage_map_as_text($type, $legend_flag)
 Function: Format a text-graphic representation of the
           coverage map
 Returns : an array of scalar strings, suitable for printing
 Args    : $type: one of 'query', 'hit', 'subject'
           $context: strand/frame context string
           $legend_flag: boolean; add a legend indicating
            the actual interval coordinates for each component
            interval and hsp (in the $type sequence context)
 Example : print $tiling->coverage_map_as_text('query',1);

=cut

sub coverage_map_as_text{
    my $self = shift;
    my ($type, $context, $legend_q) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_context_arg($type, \$context);

    my @map = $self->coverage_map($type, $context);
    my @ret;
    my @hsps = $self->hit->hsps;
    my %hsps_i;
    require Tie::RefHash;
    tie %hsps_i, 'Tie::RefHash';
    @hsps_i{@hsps} = (0..$#hsps);
    my @mx;
    foreach (0..$#map) {
	my @hspx = ('') x @hsps;
	my @these_hsps = @{$map[$_]->[1]};
	@hspx[@hsps_i{@these_hsps}] = ('*') x @these_hsps;
	$mx[$_] = \@hspx;
    }
    untie %hsps_i;

    push @ret, "\tIntvl\n";
    push @ret, "HSPS\t", join ("\t", (0..$#map)), "\n";
    foreach my $h (0..$#hsps) {
	push @ret, join("\t", $h, map { $mx[$_][$h] } (0..$#map)  ),"\n";
    }
    if ($legend_q) {
	push @ret, "Interval legend\n";
	foreach (0..$#map) {
	    push @ret, sprintf("%d\t[%d, %d]\n", $_, @{$map[$_][0]});
	}
	push @ret, "HSP legend\n";
	my @ints = get_intervals_from_hsps($type,@hsps);
	foreach (0..$#hsps) {
	    push @ret, sprintf("%d\t[%d, %d]\n", $_, @{$ints[$_]});
	}
    }
    return @ret;
}

=head2 hit

 Title   : hit
 Usage   : $tiling->hit
 Function: 
 Example : 
 Returns : The HitI object associated with the invocant
 Args    : none
 Note    : getter only 

=cut

sub hit{
    my $self = shift;
    $self->warn("Getter only") if @_;
    return $self->{'hit'};
}

=head2 hsps

 Title   : hsps
 Usage   : $tiling->hsps()
 Function: Container for the HSP objects associated with invocant
 Example : 
 Returns : an array of hsps associated with the hit
 Args    : on set, new value (an arrayref or undef, optional)

=cut

sub hsps{
    my $self = shift;
    return $self->{'hsps'} = shift if @_;
    return @{$self->{'hsps'}};
}

=head2 contexts

 Title   : contexts
 Usage   : @contexts = $tiling->context($type) or
           @indices = $tiling->context($type, $context)
 Function: Retrieve the set of available contexts in the hit,
           or the indices of hsps having the given context
           (integer indices for the array returned by $self->hsps)
 Returns : array of scalar context strings or 
           array of scalar positive integers
           undef if no hsps in given context
 Args    : $type: one of 'query', 'hit', 'subject'
           optional $context: context string

=cut

sub contexts{
    my $self = shift;
    my ($type, $context) = @_;
    $self->_check_type_arg(\$type);
    return keys %{$self->{"_contexts_$type"}} unless defined $context;
    return undef unless $self->{"_contexts_$type"}{$context};
    return @{$self->{"_contexts_$type"}{$context}};
}

=head2 mapping

 Title   : mapping
 Usage   : $tiling->mapping($type)
 Function: Retrieve the mapping coefficient for the sequence type
           based on the underlying algorithm
 Returns : scalar integer (mapping coefficient)
 Args    : $type: one of 'query', 'hit', 'subject'
 Note    : getter only (set in constructor)

=cut

sub mapping{
    my $self = shift;
    my $type = shift;
    $self->_check_type_arg(\$type);
    return $self->{"_mapping_${type}"};
}

=head2 default_context

 Title   : default_context
 Usage   : $tiling->default_context($type)
 Function: Retrieve the default strand/frame context string
           for the sequence type based on the underlying algorithm
 Returns : scalar string (context string)
 Args    : $type: one of 'query', 'hit', 'subject'
 Note    : getter only (set in constructor)

=cut

sub default_context{
    my $self = shift;
    my $type = shift;
    $self->_check_type_arg(\$type);
    return $self->{"_def_context_${type}"};
}

=head2 algorithm

 Title   : algorithm
 Usage   : $tiling->algorithm
 Function: Retrieve the algorithm name associated with the 
           invocant's hit object
 Returns : scalar string 
 Args    : none
 Note    : getter only (set in constructor)

=cut

sub algorithm{
    my $self = shift;
    $self->warn("Getter only") if @_;
    return $self->{"_algorithm"};
}

=head1 "PRIVATE" METHODS

=head2 Calculators

See L<Bio::Search::Tiling::MapTileUtils> for lower level
calculation methods.

=head2 _calc_coverage_map

 Title   : _calc_coverage_map
 Usage   : $tiling->_calc_coverage_map($type)
 Function: Calculates the coverage map for the object's associated
           hit from the perspective of the desired $type (see Args:) 
           and sets the coverage_map() property
 Returns : True on success
 Args    : optional scalar $type: one of 'hit'|'subject'|'query'
           default is 'query'
 Note    : The "coverage map" is an array with the following format:
           ( [ $component_interval => [ @containing_hsps ] ], ... ),
           where $component_interval is a closed interval (see 
           DESCRIPTION) of the form [$a0, $a1] with $a0 <= $a1, and
           @containing_hsps is an array of all HspI objects in the hit 
           which completely contain the $component_interval.
           The set of $component_interval's is a disjoint decomposition
           of the minimum set of minimal intervals that completely
           cover the hit's HSPs (from the perspective of the $type)
 Note    : This calculates the map for all strand/frame contexts available
           in the hit

=cut

sub _calc_coverage_map {
    my $self = shift;
    my ($type) = @_;
    $self->_check_type_arg(\$type);

    # obtain the [start, end] intervals for all hsps in the hit (relative
    # to the type)
    unless ($self->{'hsps'}) {
	$self->warn("No HSPs for this hit");
	return;
    }

    my (@map, @hsps, %filters, @intervals);
    

    # conversion here?
    my $c = $self->mapping($type);
    
    # create the possible maps 
    for my $context ($self->contexts($type)) {
	@map = ();
	@hsps = ($self->hsps)[$self->contexts($type, $context)];
	@intervals = get_intervals_from_hsps( $type, @hsps );
	# the "frame"
	my $f = ($intervals[0]->[0] - 1) % $c;

	# convert interval endpoints...
	for (@intervals) {
	    $$_[0] = ($$_[0] - $f + $c - 1)/$c;
	    $$_[1]  = ($$_[1] - $f)/$c;
	}
	
	# determine the minimal set of disjoint intervals that cover the
	# set of hsp intervals
	my @dj_set = interval_tiling(\@intervals);

	# decompose each disjoint interval into another set of disjoint 
	# intervals, each of which is completely contained within the
	# original hsp intervals with which it overlaps
	my $i=0;
	my @decomp;
	for my $dj_elt (@dj_set) {
	    my ($covering, $indices) = @$dj_elt;
	    my @covering_hsps = @hsps[@$indices];
	    my @coverers = @intervals[@$indices];
	    @decomp = decompose_interval( \@coverers );
	    for (@decomp) {
		my ($component, $container_indices) = @{$_};
		push @map, [ $component, 
			     [@covering_hsps[@$container_indices]] ];
	    }
	    1;
	}
    
	# unconvert the components:
#####
	foreach (@map) {
	    $$_[0][0] = $c*$$_[0][0] - $c + 1 + $f;
	    $$_[0][1] = $c*$$_[0][1] + $f;
	}
	foreach (@dj_set) {
	    $$_[0][0] = $c*$$_[0][0] - $c + 1 + $f;
	    $$_[0][1] = $c*$$_[0][1] + $f;
	}	    

	# sort the map on the interval left-ends
	@map = sort { $a->[0][0]<=>$b->[0][0] } @map;
	$self->{"coverage_map_${type}_${context}"} = [@map];
	# set the _contig_intersection attribute here (side effect)
	$self->{"_contig_intersection_${type}_${context}"} = [map { $$_[0] } @dj_set];
    }

    return 1; # success
}

=head2 _calc_stats

 Title   : _calc_stats
 Usage   : $tiling->_calc_stats($type, $action, $context)
 Function: Calculates [estimated] tiling statistics (identities, conserved sites
           length) and sets the public accessors
 Returns : True on success
 Args    : scalar $type: one of 'hit', 'subject', 'query'
           default is 'query'
           optional scalar $action: requests calculation method
            currently one of 'exact', 'est', 'fast', 'max'
           option scalar $context: strand/frame context string
 Note    : Action: The statistics are calculated by summing quantities
           over the disjoint component intervals, taking into account
           coverage of those intervals by multiple HSPs. The action
           tells the algorithm how to obtain those quantities--
           'exact' will use Bio::Search::HSP::HSPI::matches
            to count the appropriate segment of the homology string;
           'est' will estimate the statistics by multiplying the 
            fraction of the HSP overlapped by the component interval
            (see MapTileUtils) by the BLAST-reported identities/postives
            (this may be convenient for BLAST summary report formats)
           * Both exact and est take the average over the number of HSPs
             that overlap the component interval.
           'max' uses the exact method to calculate the statistics, 
            and returns only the maximum identites/positives over 
            overlapping HSP for the component interval. No averaging
            is involved here.
           'fast' doesn't involve tiling at all (hence the name),
            but it seems like a very good estimate, and uses only
            reported values, and so does not require sequence data. It
            calculates an average of reported identities, conserved
            sites, and lengths, over unmodified hsps in the hit,
            weighted by the length of the hsps.  

=cut

sub _calc_stats {
    my $self = shift;
    my ($type, $action, $context) = @_;
    # need to check args here, in case method is called internally.
    $self->_check_type_arg(\$type);
    $self->_check_action_arg(\$action);
    $self->_check_context_arg($type, \$context);
    my ($ident, $cons, $length) = (0,0,0);

    # fast : avoid coverage map altogether, get a pretty damn
    # good estimate with a weighted average of reported hsp
    # statistics

    ($action eq 'fast') && do {
	my @hsps = $self->hit->hsps;
	@hsps = @hsps[$self->contexts($type, $context)];
	# weights for averages
	my @wt = map {$_->length($type)} @hsps;
	my $sum = eval( join('+',@wt) );
	$_ /= $sum for (@wt);
	for (@hsps) { 
	    my $wt = shift @wt;
	    $ident  += $wt*$_->matches_MT($type,'identities');
	    $cons   += $wt*$_->matches_MT($type,'conserved');
	    $length += $wt*$_->length($type);
	}
    };

    # or, do tiling

    # calculate identities/conserved sites in tiling
    # estimate based on the fraction of the component interval covered
    # and ident/cons reported by the HSPs
    ($action ne 'fast') && do {
	foreach ($self->coverage_map($type, $context)) {
	    my ($intvl, $hsps) = @{$_};
	    my $len = ($$intvl[1]-$$intvl[0]+1);
	    my $ncover = ($action eq 'max') ? 1 : scalar @$hsps;
	    my ($acc_i, $acc_c) = (0,0);
	    foreach my $hsp (@$hsps) {
		for ($action) {
		    ($_ eq 'est') && do {
			my ($inc_i, $inc_c) = $hsp->matches_MT(
			    -type   => $type,
			    -action => 'searchutils',
			    );
			my $frac = $len/$hsp->length($type);
			$acc_i += $inc_i * $frac;
			$acc_c += $inc_c * $frac;
			last;
		    };
		    ($_ eq 'max') && do {
			my ($inc_i, $inc_c) = $hsp->matches_MT(
			    -type   => $type,
			    -action => 'searchutils',
			    -start => $$intvl[0], 
			    -end   => $$intvl[1]
			    );
			$acc_i = ($acc_i > $inc_i) ? $acc_i : $inc_i;
			$acc_c = ($acc_c > $inc_c) ? $acc_c : $inc_c;
			last;
		    };
		    (!$_ || ($_ eq 'exact')) && do {
			my ($inc_i, $inc_c) = $hsp->matches_MT(
			    -type   => $type, 
			    -action => 'searchutils',
			    -start  => $$intvl[0], 
			    -end    => $$intvl[1]
			    );
			$acc_i += $inc_i;
			$acc_c += $inc_c;
			last;
		    };
		}
	    }
	    $ident += ($acc_i/$ncover);
	    $cons  += ($acc_c/$ncover);
	    $length += $len;
	}
    };
    
    $self->{"identities_${type}_${action}_${context}"} = $ident;
    $self->{"conserved_${type}_${action}_${context}"} = $cons;
    $self->{"length_${type}_${action}_${context}"} = $length;
    
    return 1;
}

=head2 Tiling Helper Methods

=cut

# coverage_map is of the form
# ( [ $interval, \@containing_hsps ], ... )

# so, for each interval, pick one of the containing hsps,
# and return the union of all the picks.

# use the combinatorial generating iterator, with 
# the urns containing the @containing_hsps for each
# interval

=head2 _make_tiling_iterator

 Title   : _make_tiling_iterator
 Usage   : $self->_make_tiling_iterator($type)
 Function: Create an iterator code ref that will step through all 
           minimal combinations of HSPs that produce complete coverage
           of the $type ('hit', 'subject', 'query') sequence, 
           and set the correct iterator property of the invocant
 Example :
 Returns : True on success
 Args    : scalar $type, one of 'hit', 'subject', 'query';
           default is 'query'

=cut

sub _make_tiling_iterator {
    ### create the urns
    my $self = shift;
    my ($type, $context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_context_arg($type, \$context);

    # initialize the urns
    my @urns = map { [0,  $$_[1]] } $self->coverage_map($type, $context);

    my $FINISHED = 0;
    my $iter = sub {
	# rewind?
	if (my $rewind = shift) {
	    # reinitialize urn indices
	    $$_[0] = 0 for (@urns);
	    $FINISHED = 0;
	    return 1;
	}	    
	# check if done...
        return if $FINISHED;

        my $finished_incrementing = 0;
	# @ret is the collector of urn choices
	my @ret;

	for my $urn (@urns) {
	    my ($n, $hsps) = @$urn;
	    push @ret, $$hsps[$n];
	    unless ($finished_incrementing) {
		if ($n == $#$hsps) { $$urn[0] = 0; }
		else { ($$urn[0])++; $finished_incrementing = 1 }
	    }
	}

	# backstop...
        $FINISHED = 1 unless $finished_incrementing;
	# uniquify @ret
	# $hsp->rank is a unique identifier for an hsp in a hit.
	# preserve order in @ret
	
	my (%order, %uniq);
	@order{(0..$#ret)} = @ret;
	$uniq{$order{$_}->rank} = $_ for (0..$#ret);
	@ret = @order{ sort {$a<=>$b} values %uniq };

        return @ret;
    };

    $self->{"_tiling_iterator_${type}_${context}"} = $iter;
    return 1;
}

=head2 _tiling_iterator

 Title   : _tiling_iterator
 Usage   : $tiling->_tiling_iterator($type,$context)
 Function: Retrieve the tiling iterator coderef for the requested 
           $type ('hit', 'subject', 'query')
 Example : 
 Returns : coderef to the desired iterator
 Args    : scalar $type, one of 'hit', 'subject', 'query'
           default is 'query'
           option scalar $context: strand/frame context string
 Note    : getter only

=cut

sub _tiling_iterator {
    my $self = shift;
    my ($type, $context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_context_arg($type, \$context);

    if (!defined $self->{"_tiling_iterator_${type}_${context}"}) {
	$self->_make_tiling_iterator($type,$context);
    }
    return $self->{"_tiling_iterator_${type}_${context}"};
}

=head2 Construction Helper Methods

See also L<Bio::Search::Tiling::MapTileUtils>.

=cut

sub _check_type_arg {
    my $self = shift;
    my $typeref = shift;
    $$typeref ||= 'query';
    $self->throw("Unknown type '$$typeref'") unless grep(/^$$typeref$/, qw( hit query subject ));    
    $$typeref = 'hit' if $$typeref eq 'subject';
    return 1;
}

sub _check_action_arg {
    my $self = shift;
    my $actionref = shift;
    if (!$$actionref) {
	$$actionref = ($self->_has_sequence_data ? 'exact' : 'est');
    }
    else {
	$self->throw("Calc action '$$actionref' unrecognized") unless grep /^$$actionref$/, qw( est exact fast max );
	if ($$actionref ne 'est' and !$self->_has_sequence_data) {
	    $self->warn("Blast file did not possess sequence data; defaulting to 'est' action");
	    $$actionref = 'est';
	}
    }
    return 1;
}

sub _check_context_arg {
    my $self = shift;
    my ($type, $contextref) = @_;
    if (!$$contextref) {
	$self->throw("Type '$type' requires strand/frame context for algorithm ".$self->algorithm) unless ($self->mapping($type) == 1);
	# set default according to default_context attrib
	$$contextref = $self->default_context($type);
    }
    else {
	($$contextref =~ /^[mp]$/) && do { $$contextref .= '_' };
	$self->throw("Context '$$contextref' unrecognized") unless
	    $$contextref =~ /all|[mp][0-2_]/;
    }
	
}

=head2 _make_context_key

 Title   : _make_context_key
 Alias   : _context
 Usage   : $tiling->_make_context_key(-strand => $strand, -frame => $frame)
 Function: create a string indicating strand/frame context; serves as 
           component of memoizing hash keys
 Returns : scalar string
 Args    : -type => one of ('query', 'hit', 'subject')
           -strand => one of (1,0,-1)
           -frame  => one of (-2, 1, 0, 1, -2)
           called w/o args: returns 'all'

=cut

sub _make_context_key {
    my $self = shift;
    my @args = @_;
    my ($type, $strand, $frame) = $self->_rearrange([qw(TYPE STRAND FRAME)], @args);
    _check_type_arg(\$type);
    return 'all' unless (defined $strand or defined $frame);
    if ( defined $strand && $self->_has_strand($type) ) {
	if (defined $frame && $self->_has_frame($type)) {
	    return ($strand >= 0 ? 'p' : 'm').abs($frame);
	}
	else {
	    return ($strand >= 0 ? 'p_' : 'm_');
	}
    }
    else {
	if (defined $frame && $self->_has_frame($type)) {
	    $self->warn("Frame defined without strand; punting with plus strand");
	    return 'p'.abs($frame);
	}
	else {
	    return 'all';
	}
    }
}

=head2 _context

 Title   : _context
 Alias   : _make_context_key
 Usage   : $tiling->_make_context_key(-strand => $strand, -frame => $frame)
 Function: create a string indicating strand/frame context; serves as 
           component of memoizing hash keys
 Returns : scalar string
 Args    : -type => one of ('query', 'hit', 'subject')
           -strand => one of (1,0,-1)
           -frame  => one of (-2, 1, 0, 1, -2)
           called w/o args: returns 'all'

=cut

sub _context { shift->_make_context_key(@_) }

=head2 Predicates

Most based on a reading of the algorithm name with a configuration lookup.

=over

=item _has_sequence_data()

=cut 

sub _has_sequence_data {
    my $self = shift;
    $self->throw("Hit attribute  not yet set") unless defined $self->hit;
    return (($self->hit->hsps)[0]->seq_str('match') ? 1 : 0);
}

=item _has_logical_length()

=cut

sub _has_logical_length {
    my $self = shift;
    my $type = shift;
    $self->_check_type_arg(\$type);
    # based on mapping coeff
    $self->throw("Mapping coefficients not yet set") unless defined $self->mapping($type);
    return ($self->mapping($type) > 1);
}

=item _has_strand()

=cut

sub _has_strand {
    my $self = shift;
    my $type = shift;
    $self->_check_type_arg(\$type);
    return $self->{"_has_strand_${type}"};
}

=item _has_frame()

=cut

sub _has_frame {
    my $self = shift;
    my $type = shift;
    $self->_check_type_arg(\$type);
    return $self->{"_has_frame_${type}"};
}

=back

=head1 Private Accessors

=head2 _contig_intersection

 Title   : _contig_intersection
 Usage   : $tiling->_contig_intersection($type)
 Function: Return the minimal set of $type coordinate intervals
           covered by the invocant's HSPs
 Returns : array of intervals (2-member arrayrefs; see MapTileUtils)
 Args    : scalar $type: one of 'query', 'hit', 'subject'

=cut

sub _contig_intersection {
    my $self = shift;
    my ($type, $context) = @_;
    $self->_check_type_arg(\$type);
    $self->_check_context_arg($type, \$context);
    if (!defined $self->{"_contig_intersection_${type}_${context}"}) {
	$self->_calc_coverage_map($type);
    }
    return @{$self->{"_contig_intersection_${type}_${context}"}};
}

=head2 _reported_length

 Title   : _reported_length
 Usage   : $tiling->_reported_length($type)
 Function: Get the total length of the seq $type
           for the invocant's hit object, as reported
           by (not calculated from) the input data file
 Returns : scalar int
 Args    : scalar $type: one of 'query', 'hit', 'subject'
 Note    : This is kludgy; the hit object does not currently
           maintain accessors for these values, but the 
           hsps possess these attributes. This is a wrapper
           that allows a consistent access method in the 
           MapTiling code.
 Note    : Since this number is based on a reported length,
           it is already a "logical length". 

=cut

sub _reported_length {
    my $self = shift;
    my $type = shift;
    $self->_check_type_arg(\$type);
    my $key = uc( $type."_LENGTH" );
    return ($self->hsps)[0]->{$key};
}

1;