sub to_string
{ my ($self,$result,$num) = @_;
$num ||= 0;
return unless defined $result;
my $links = $self->no_wublastlinks;
my ($resultfilter,$hitfilter, $hspfilter) = ( $self->filter('RESULT'),
$self->filter('HIT'),
$self->filter('HSP') );
return '' if( defined $resultfilter && ! &{$resultfilter}($result) );
my ($qtype,$dbtype,$dbseqtype,$type);
my $alg = $result->algorithm;
if( $alg =~ /T(FAST|BLAST)([XY])/i ) {
$qtype = $dbtype = 'translated';
$dbseqtype = $type = 'PROTEIN';
} elsif( $alg =~ /T(FAST|BLAST)N/i ) {
$qtype = '';
$dbtype = 'translated';
$type = 'PROTEIN';
$dbseqtype = 'NUCLEOTIDE';
} elsif( $alg =~ /(FAST|BLAST)N/i ||
$alg =~ /(WABA|EXONERATE)/i ) {
$qtype = $dbtype = '';
$type = $dbseqtype = 'NUCLEOTIDE';
} elsif( $alg =~ /(FAST|BLAST)P/ || $alg =~ /SSEARCH/i ) {
$qtype = $dbtype = '';
$type = $dbseqtype = 'PROTEIN';
} elsif( $alg =~ /(FAST|BLAST)[XY]/i ) {
$qtype = 'translated';
$dbtype = 'PROTEIN';
$dbseqtype = $type = 'PROTEIN';
} else {
print STDERR "algorithm was ", $result->algorithm, " couldn't match\n";
}
my %baselens = ( 'Sbjct:' => ( $dbtype eq 'translated' ) ? 3 : 1,
'Query:' => ( $qtype eq 'translated' ) ? 3 : 1);
my $str;
if( ! defined $num || $num <= 1 ) {
$str = &{$self->start_report}($result);
}
$str .= &{$self->title}($result);
$str .= $result->algorithm_reference || $self->algorithm_reference($result);
$str .= &{$self->introduction}($result);
$str .= "<table border=0>
<tr><th>Sequences producing significant alignments:</th>
<th>Score<br>(bits)</th><th>E<br>value</th></tr>";
my $hspstr = '<p><p>';
if( $result->can('rewind')) {
$result->rewind(); }
while( my $hit = $result->next_hit ) {
next if( $hitfilter && ! &{$hitfilter}($hit) );
my $nm = $hit->name();
$self->debug( "no $nm for name (".$hit->description(). "\n")
unless $nm;
my ($gi,$acc) = &{$self->id_parser}($nm);
my $p = "%-$MaxDescLen". "s";
my $descsub;
if( length($hit->description) > ($MaxDescLen - 3) ) {
$descsub = sprintf($p,
substr($hit->description,0,$MaxDescLen-3) . "...");
} else {
$descsub = sprintf($p,$hit->description);
}
my $url_desc = &{$self->hit_link_desc()}($self,$hit, $result);
my $url_align = &{$self->hit_link_align()}($self,$hit, $result);
my @hsps = $hit->hsps;
if( ! @hsps ) {
$str .= sprintf('<tr><td>%s %s</td><td>%s</td><td>%.2g</td></tr>'."\n",
$url_desc, $descsub,
($hit->raw_score ? $hit->raw_score :
(defined $hsps[0] ? $hsps[0]->score : ' ')),
( $hit->significance ? $hit->significance :
(defined $hsps[0] ? $hsps[0]->evalue : ' '))
);
} else {
$str .= sprintf('<tr><td>%s %s</td><td>%s</td><td><a href="#%s">%.2g</a></td></tr>'."\n",
$url_desc, $descsub,
($hit->raw_score ? $hit->raw_score :
(defined $hsps[0] ? $hsps[0]->score : ' ')),
$acc,
( $hit->significance ? $hit->significance :
(defined $hsps[0] ? $hsps[0]->evalue : ' '))
);
$hspstr .= "<a name=\"$acc\">\n".
sprintf("><b>%s</b> %s\n<dd>Length = %s</dd><p>\n\n", $url_align,
defined $hit->description ? $hit->description : '',
&_numwithcommas($hit->length));
my $ct = 0;
foreach my $hsp (@hsps ) {
next if( $hspfilter && ! &{$hspfilter}($hsp) );
$hspstr .= sprintf(" Score = %s bits (%s), Expect = %s",
$hsp->bits, $hsp->score, $hsp->evalue);
if( defined $hsp->pvalue ) {
$hspstr .= ", P = ".$hsp->pvalue;
}
$hspstr .= "<br>\n";
$hspstr .= sprintf(" Identities = %d/%d (%d%%)",
( $hsp->frac_identical('total') *
$hsp->length('total')),
$hsp->length('total'),
$hsp->frac_identical('total') * 100);
if( $type eq 'PROTEIN' ) {
$hspstr .= sprintf(", Positives = %d/%d (%d%%)",
( $hsp->frac_conserved('total') *
$hsp->length('total')),
$hsp->length('total'),
$hsp->frac_conserved('total') * 100);
}
if( $hsp->gaps ) {
$hspstr .= sprintf(", Gaps = %d/%d (%d%%)",
$hsp->gaps('total'),
$hsp->length('total'),
(100 * $hsp->gaps('total') / $hsp->length('total'))); }
my ($hframe,$qframe) = ( $hsp->hit->frame, $hsp->query->frame);
my ($hstrand,$qstrand) = ($hsp->hit->strand,$hsp->query->strand);
if( $hstrand || $qstrand ) {
$hspstr .= ", Frame = ";
my ($signq, $signh);
unless( $hstrand ) {
$hframe = undef;
} else {
$signh = $hstrand < 0 ? '-' : '+';
}
unless( $qstrand ) {
$qframe = undef;
} else {
$signq =$qstrand < 0 ? '-' : '+';
}
if( defined $hframe && ! defined $qframe) {
$hspstr .= "$signh".($hframe+1);
} elsif( defined $qframe && ! defined $hframe) {
$hspstr .= "$signq".($qframe+1);
} else {
$hspstr .= sprintf(" %s%d / %s%d",
$signq,$qframe+1,
$signh, $hframe+1);
}
}
if($links &&
$hsp->can('links') && defined(my $lnks = $hsp->links) ) {
$hspstr .= sprintf("<br>\nLinks = %s\n",$lnks);
}
$hspstr .= "</a><p>\n<pre>";
my @hspvals = ( {'name' => 'Query:',
'seq' => $hsp->query_string,
'start' => ($qstrand >= 0 ?
$hsp->query->start :
$hsp->query->end),
'end' => ($qstrand >= 0 ?
$hsp->query->end :
$hsp->query->start),
'index' => 0,
'direction' => $qstrand || 1
},
{ 'name' => ' 'x6,
'seq' => $hsp->homology_string,
'start' => undef,
'end' => undef,
'index' => 0,
'direction' => 1
},
{ 'name' => 'Sbjct:',
'seq' => $hsp->hit_string,
'start' => ($hstrand >= 0 ?
$hsp->hit->start :
$hsp->hit->end),
'end' => ($hstrand >= 0 ?
$hsp->hit->end :
$hsp->hit->start),
'index' => 0,
'direction' => $hstrand || 1
}
);
my ($numwidth) = sort { $b <=> $a }(length($hspvals[0]->{'start'}),
length($hspvals[0]->{'end'}),
length($hspvals[2]->{'start'}),
length($hspvals[2]->{'end'}));
my $count = 0;
while ( $count <= $hsp->length('total') ) {
foreach my $v ( @hspvals ) {
my $piece = substr($v->{'seq'}, $v->{'index'} + $count,
$AlignmentLineWidth);
my $cp = $piece;
my $plen = scalar ( $cp =~ tr/\-//);
my ($start,$end) = ('','');
if( defined $v->{'start'} ) {
$start = $v->{'start'};
my $d = $v->{'direction'} * ( $AlignmentLineWidth - $plen )*
$baselens{$v->{'name'}};
if( length($piece) < $AlignmentLineWidth ) {
$d = (length($piece) - $plen) * $v->{'direction'} *
$baselens{$v->{'name'}};
}
$end = $v->{'start'} + $d - $v->{'direction'};
$v->{'start'} += $d;
}
$hspstr .= sprintf("%s %-".$numwidth."s %s %s\n",
$v->{'name'},
$start,
$piece,
$end
);
}
$count += $AlignmentLineWidth;
$hspstr .= "\n\n";
}
$hspstr .= "</pre>\n";
}
}
}
$str .= "</table><p>\n".$hspstr."<p><p><hr><h2>Search Parameters</h2><table border=1><tr><th>Parameter</th><th>Value</th>\n";
foreach my $param ( sort $result->available_parameters ) {
$str .= "<tr><td>$param</td><td>". $result->get_parameter($param) ."</td></tr>\n";
}
$str .= "</table><p><h2>Search Statistics</h2><table border=1><tr><th>Statistic</th><th>Value</th></tr>\n";
foreach my $stat ( sort $result->available_statistics ) {
$str .= "<tr><td>$stat</td><td>". $result->get_statistic($stat). "</td></th>\n";
}
$str .= "</table><P>".$self->footer() . "<P>\n";
return $str;} |
sub default_title
{ my ($result) = @_;
return sprintf(
qq{<CENTER><H1><a href="http://bioperl.org">Bioperl</a> Reformatted HTML of %s Search Report<br> for %s</H1></CENTER>},
$result->algorithm,
$result->query_name());
}
=head2 introduction
Title : introduction
Usage : $self->introduction($CODE)
Function: Stores or returns the code to provide HTML for the given
BLAST report detailing the query and the
database information.
Useful for (for instance) specifying
routines returning alternative introductions.
Returns\& default_introduction (see below) if not
set.
Example : $index->introduction(\& my_introduction )
Returns : ref to CODE if called without arguments
Args : CODE
=cut
sub introduction {
my( $self, $code ) = @_;
if ($code) {
$self->{'_introduction'} = $code;
}
return $self->{'_introduction'} ||\& default_introduction;
}
=head2 default_introduction
Title : default_introduction
Usage : $self->default_introduction($result)
Function: Outputs HTML to provide the query
and the database information
Returns : string containing HTML
Args : First argument is a Bio::Search::Result::ResultI
Second argument is string holding literature citation
=cut
sub default_introduction {
my ($result) = @_;
return sprintf(
qq{
<b>Query=</b> %s %s<br><dd>(%s letters)</dd>
<p>
<b>Database:</b> %s<br><dd>%s sequences; %s total letters<p></dd>
<p>
},
$result->query_name,
$result->query_description,
&_numwithcommas($result->query_length),
$result->database_name(),
&_numwithcommas($result->database_entries()),
&_numwithcommas($result->database_letters()),
);
}
=head2 end_report
Title : end_report
Usage : $self->end_report()
Function: The method to call when ending a report, this is
mostly for cleanup for formats which require you to
have something at the end of the document (</BODY></HTML>)
for HTML
Returns : string
Args : none
=cut
sub end_report {
return "</BODY>\n</HTML>\n";
}
=head2 id_parser
Title : id_parser
Usage : $index->id_parser( CODE )
Function: Stores or returns the code used by record_id to
parse the ID for record from a string. Useful
for (for instance) specifying a different
parser for different flavours of FASTA file.
Returns\& default_id_parser (see below) if not
set. If you supply your own id_parser
subroutine, then it should expect a fasta
description line. An entry will be added to
the index for each string in the list returned.
Example : $index->id_parser(\& my_id_parser )
Returns : ref to CODE if called without arguments
Args : CODE
=cut
sub id_parser {
my( $self, $code ) = @_;
if ($code) {
$self->{'_id_parser'} = $code;
}
return $self->{'_id_parser'} ||\& default_id_parser;
}
=head2 default_id_parser
Title : default_id_parser
Usage : $id = default_id_parser( $header )
Function: The default Fasta ID parser for Fasta.pm
Returns $1 from applying the regexp /^>\s*(\S+)/
to $header.
Returns : ID string
The default implementation checks for NCBI-style
identifiers in the given string ('gi|12345|AA54321').
For these IDs, it extracts the GI and accession and
returns a two-element list of strings (GI, acc).
Args : a fasta header line string
=cut
sub default_id_parser {
my ($string) = @_;
my ($gi,$acc);
if( $string =~ s/gi\|(\d+)\|?// )
{ $gi = $1; $acc = $1;}
if( $string =~ /(\w+)\|([A-Z\d\.\_]+)(\|[A-Z\d\_]+)?/ ) {
$acc = defined $2 ? $2 : $1;
} else {
$acc = $string;
$acc =~ s/^\s+(\S+)/$1/;
$acc =~ s/(\S+)\s+$/$1/;
}
return ($gi,$acc);
}
sub MIN { $a <=> $b ? $a : $b; }
sub MAX { $a <=> $b ? $b : $a; }
sub footer {
my ($self) = @_;
return "<hr><h5>Produced by Bioperl module ".ref($self)." on $DATE<br>Revision: $Revision</h5>\n"
}
=head2 algorithm_reference
Title : algorithm_reference
Usage : my $reference = $writer->algorithm_reference($result);
Function: Returns the appropriate Bibliographic reference for the
algorithm format being produced
Returns : String
Args : L<Bio::Search::Result::ResultI> to reference
=cut
sub algorithm_reference {
my ($self,$result) = @_;
return '' if( ! defined $result || !ref($result) ||
! $result->isa('Bio::Search::Result::ResultI')) ;
if( $result->algorithm =~ /BLAST/i ) {
my $res = $result->algorithm . ' ' . $result->algorithm_version . "<p>";
if( $result->algorithm_version =~ /WashU/i ) {
return $res .
"Copyright (C) 1996-2000 Washington University, Saint Louis, Missouri USA.<br>
All Rights Reserved.<p>
<b>Reference:</b> Gish, W. (1996-2000) <a href=\"http://blast.wustl.edu\">http://blast.wustl.edu</a><p>";
} else {
return $res .
"<b>Reference:</b> Altschul, Stephen F., Thomas L. Madden, Alejandro A. Schaffer,<br>
Jinghui Zhang, Zheng Zhang, Webb Miller, and David J. Lipman (1997),<br>\"
Gapped BLAST and PSI-BLAST: a new generation of protein database search<br>
programs\", Nucleic Acids Res. 25:3389-3402.<p>";
}
} elsif( $result->algorithm =~ /FAST/i ) {
return $result->algorithm . " " . $result->algorithm_version . "<br>" .
"\n<b>Reference:</b> Pearson et al, Genomics (1997) 46:24-36<p>";
} else {
return '';
}
}
sub _numwithcommas {
my $num = reverse( $_[0] );
$num =~ s/(\d{3})(?=\d)(?!\d*\.)/$1,/g;
return scalar reverse $num;
}
=head2 Methods Bio::SearchIO::SearchWriterI
L<Bio::SearchIO::SearchWriterI> inherited methods.
=head2 filter
Title : filter
Usage : $writer->filter('hsp',\& hsp_filter);
Function: Filter out either at HSP,Hit,or Result level
Returns : none
Args : string => data type,
CODE reference
=cut
=head2 no_wublastlinks
Title : no_wublastlinks
Usage : $obj->no_wublastlinks($newval)
Function: Get/Set boolean value regarding whether or not to display Link = (1) type output in the report output (WU-BLAST only) Returns : boolean Args : on set, new boolean value (a scalar or undef, optional)
=cut
sub no_wublastlinks{ my $self = shift;
return $self->{'no_wublastlinks'} = shift if @_;
return $self->{'no_wublastlinks'};
}
1;} |
The rest of the documentation details each of the object methods.
Internal methods are usually preceded with a _