examples/tk/hitdisplay.pl

   1 #!/usr/bin/perl
   2 #
   3 # PROGRAM  : hitdisplay.pl
   4 # PURPOSE  : Demonstrate Bio::Tk::HitDisplay
   5 # AUTHOR   : Keith James kdj@sanger.ac.uk
   6 # CREATED  : Nov 1 2000
   7 #
   8 # Requires Bio::Tk::HitDisplay
   9 #
  10 # To use, just pipe Blast output into this script. Try clicking on
  11 # the blue Subject ids with the left button to activate a callback
  12 # or with the right button to show text describing the hit.
  13 #
  14
  15 use strict;
  16 use Text::Wrap qw(wrap $columns);
  17 use Bio::Tools::BPlite;
  18 BEGIN {
  19         print STDERR "This example uses deprecated BioPerl code; feel free to refactor as needed\n";
  20         exit;
  21     eval {
  22         require 'Tk.pm';
  23         require 'Bio/Tk/HitDisplay.pm';
  24     };
  25     if( $@ ) {
  26         print STDERR "Must have bioperl-gui and Tk installed to run this test, see bioperl website www.bioperl.org for instructions on how to installed bioperl-gui modules\n";
  27         exit;
  28     }
  29
  30 }
  31 use Tk;
  32     $columns = 80;
  33
  34 my $report = Bio::Tools::BPlite->new(-fh => \*STDIN);
  35
  36 # Normally the code ref below is in a separate package and I do
  37 # something like:
  38 #
  39 # my $adapter = Bio::PSU::IO::Blast::HitAdapter->new;
  40 #
  41 # while (my $hit = $result->next_hit)
  42 # {
  43 #     my $text     = " ... ";
  44 #     my $callback = sub { ... };
  45 #     push(@hits, $adapter->($sbjct, $text, $callback));
  46 # }
  47 #
  48 # It's easy to roll your own for Fasta, or whatever.
  49
  50 my $adapter = sub
  51 {
  52     my ($sbjct, $text, $callback) = @_;
  53
  54     my (@data, $expect, $percent, $length);
  55     my ($q_id, $s_id, $q_len, $s_len);
  56
  57     while (my $hsp = $sbjct->nextHSP)
  58     {
  59         $q_id ||= $hsp->query->seqname;
  60         $s_id ||= $hsp->subject->seqname;
  61
  62         $q_len ||= $hsp->query->seqlength;
  63         $s_len ||= $hsp->subject->seqlength;
  64
  65         my $q_x1 = $hsp->query->start;
  66         my $q_x2 = $hsp->query->end;
  67
  68         my $s_x1 = $hsp->subject->start;
  69         my $s_x2 = $hsp->subject->end;
  70
  71         push(@data, [$q_x1, $q_x2,
  72                      $s_x1, $s_x2]);
  73
  74         if (defined $expect)
  75         {
  76             if ($hsp->P < $expect)
  77             {
  78                 $expect  = $hsp->P;
  79                 $percent = $hsp->percent;
  80                 $length  = $hsp->length;
  81             }
  82         }
  83         else
  84         {
  85             $expect  = $hsp->P;
  86             $percent = $hsp->percent;
  87             $length  = $hsp->length;
  88         }
  89     }
  90
  91     return { q_id     => $q_id,
  92              s_id     => $s_id,
  93              expect   => $expect,
  94              score    => $percent,
  95              overlap  => $length,
  96              q_len    => $q_len,
  97              s_len    => $s_len,
  98              data     => \@data,
  99              text     => $text,
 100              callback => $callback }
 101
 102 };
 103
 104 my @hits;
 105
 106 while (my $sbjct = $report->nextSbjct)
 107 {
 108     # Make some text to show when the left button is clicked
 109     my $text = wrap("", "", "Blast hit to: ", $sbjct->name, "\n");
 110
 111     # Make a callback to actiavte when the right button is clicked
 112     my $callback = sub { print "Blast hit to ", $sbjct->name, "\n" };
 113
 114     # Convert Subjct, text and callback into hash
 115     push(@hits, $adapter->($sbjct, $text, $callback));
 116 }
 117
 118 # Create the main window and HitDisplay
 119 my $mw = MainWindow->new;
 120 my $hds = $mw->Scrolled('HitDisplay',
 121                         -borderwidth => 5,
 122                         -scrollbars  => 'ose',
 123                         -width       => 600,
 124                         -height      => 300,
 125                         -background  => 'white',
 126                         -hitcolours  => {
 127                                          10 => 'pink',
 128                                          20 => 'purple',
 129                                          40 => 'yellow',
 130                                          60 => 'gold',
 131                                          70 => 'orange',
 132                                          90 => 'red'
 133                                         },
 134                         -interval    => 15,
 135                         -hitdata     => \@hits);
 136
 137 $hds->pack(-side => 'top', -fill => 'both', -expand => 1);
 138 $hds->waitVisibility;
 139 $hds->configure(-height => 900);
 140 $hds->configure(-scrollregion => [$hds->bbox("all")]);
 141
 142 MainLoop;