code_perl/Maasha/KISS/Track.pm

   1 package Maasha::KISS::Track;
   2
   3 # Copyright (C) 2009 Martin A. Hansen.
   4
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # http://www.gnu.org/copyleft/gpl.html
  20
  21
  22 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  23
  24
  25 # Routines for creating KISS tracks.
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 use strict;
  33 use Data::Dumper;
  34 use Maasha::Calc;
  35 use vars qw( @ISA @EXPORT );
  36
  37 @ISA = qw( Exporter );
  38
  39
  40 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  41
  42
  43 sub track_ruler
  44 {
  45     my ( $width,      # draw window width
  46          $y_offset,   # y axis draw offset
  47          $beg,        # base window beg
  48          $end,        # base window end
  49          $font_size,  # font size
  50          $color,      # font color
  51        ) = @_;
  52
  53     my ( $factor, $step, $i, $txt, $x, @ruler );
  54
  55     $factor = $width / ( $end - $beg );
  56
  57     $step = 10;
  58
  59     while ( ( $end - $beg ) / $step > 20 )
  60     {
  61         $step *= 5;
  62     }
  63
  64     for ( $i = $beg; $i < $end; $i++ )
  65     {
  66         if ( ( $i % $step ) == 0 )
  67         {
  68             $txt = "$i|";
  69             $x   = sprintf( "%.0f", ( $i - $beg - length $txt ) * $factor );
  70
  71             if ( $x > 0 and $x + ( $font_size * length $txt ) < $width )
  72             {
  73                 push @ruler, {
  74                     type      => 'text',
  75                     txt       => $txt,
  76                     font_size => $font_size,
  77                     color     => $color,
  78                     x1        => $x,
  79                     y1        => $y_offset
  80                 };
  81             }
  82         }
  83     }
  84
  85     return wantarray ? @ruler : \@ruler;
  86 }
  87
  88
  89 sub track_seq
  90 {
  91     my ( $width,       # draw window width
  92          $y_offset,    # y axis draw offset
  93          $seq,         # sequence to draw
  94          $font_size,   # font size
  95          $color,       # font color
  96        ) = @_;
  97
  98     my ( @chars, $factor, $i, @seq_list );
  99
 100     @chars = split //, $seq;
 101
 102     $factor = $width / @chars;
 103
 104     for ( $i = 0; $i < @chars; $i++ ) {
 105         push @seq_list, {
 106             type      => 'text',
 107             txt       => $chars[ $i ],
 108             font_size => $font_size,
 109             color     => $color,
 110             x1        => sprintf( "%.0f", $i * $factor ),
 111             y1        => $y_offset,
 112         };
 113     }
 114
 115     return wantarray ? @seq_list : \@seq_list;
 116 }
 117
 118
 119 sub track_feature
 120 {
 121     my ( $width,     # draw window width
 122          $y_offset,  # y axis draw offset
 123          $beg,       # base window beg
 124          $end,       # base window end
 125          $entries,   # list of unsorted KISS entries
 126        ) = @_;
 127
 128     # Returns a list.
 129
 130     my ( $feat_height, $factor, $entry, $y_step, @ladder, $w, $x1, $y1, $x2, $y2, @features );
 131
 132     @{ $entries } = sort { $a->{ 'S_BEG' } <=> $b->{ 'S_BEG' } or $a->{ 'S_END' } <=> $b->{ 'S_END' } } @{ $entries };
 133
 134     $feat_height = 5;
 135     $factor      = $width / ( $end - $beg );
 136     $y_step      = 0;
 137
 138     foreach $entry ( @{ $entries } )
 139     {
 140         $w = sprintf( "%.0f", ( $entry->{ 'S_END' } - $entry->{ 'S_BEG' } + 1 ) * $factor );
 141
 142         if ( $w >= 1 )
 143         {
 144             $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } - $beg ) * $factor );
 145
 146             for ( $y_step = 0; $y_step < @ladder; $y_step++ )
 147             {
 148                 last if $x1 >= $ladder[ $y_step ] + 1;
 149             }
 150
 151             $y1 = $y_offset + ( $feat_height * $y_step );
 152
 153             push @features, {
 154                 type       => 'rect',
 155                 line_width => $feat_height,
 156                 color      => 'green',
 157                 title      => $entry->{ 'Q_ID' },
 158                 x1         => $x1,
 159                 y1         => $y1,
 160                 x2         => $x1 + $w,
 161                 y2         => $y1 + $feat_height,
 162             };
 163
 164             push @features, feature_align( $entry, $beg, $y1, $factor, $feat_height ) if defined $entry->{ 'ALIGN' };
 165
 166             $ladder[ $y_step ] = $x1 + $w;
 167         }
 168     }
 169
 170     return wantarray ? @features : \@features;
 171 }
 172
 173
 174 sub feature_align
 175 {
 176     # 17:A>T
 177
 178     my ( $entry,         # Partial KISS entry
 179          $beg,           # base window beg
 180          $y_offset,      # y axis draw offset
 181          $factor,        # scale factor
 182          $feat_height,   # hight of feature in pixels
 183        ) = @_;
 184
 185     # Returns a list.
 186
 187     my ( $w, $align, $pos, $nt_before, $nt_after, $x1, @features );
 188
 189     $w = sprintf( "%.0f", 1 * $factor );
 190
 191     if ( $w >= 1 )
 192     {
 193         foreach $align ( split /,/, $entry->{ 'ALIGN' } )
 194         {
 195             if ( $align =~ /(\d+):(\w)>(\w)/ )
 196             {
 197                 $pos       = $1;
 198                 $nt_before = $2;
 199                 $nt_after  = $3;
 200             }
 201             else
 202             {
 203                 die;
 204             }
 205
 206             $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } + $pos - $beg ) * $factor );
 207
 208             push @features, {
 209                 type       => 'rect',
 210                 line_width => $feat_height,
 211                 color      => 'red',
 212                 title      => $align,
 213                 x1         => $x1,
 214                 y1         => $y_offset,
 215                 x2         => $x1 + $w,
 216                 y2         => $y_offset + $feat_height,
 217             };
 218
 219             if ( $w > $feat_height )
 220             {
 221                 push @features, {
 222                     type       => 'text',
 223                     font_size  => $feat_height + 2,
 224                     color      => 'black',
 225                     txt        => $nt_after,
 226                     x1         => $x1 + sprintf( "%.0f", ( $w / 2 ) ) - $feat_height / 2,
 227                     y1         => $y_offset + $feat_height,
 228                 };
 229             }
 230         }
 231     }
 232
 233     return wantarray ? @features : \@features;
 234 }
 235
 236
 237 sub track_histogram
 238 {
 239     my ( $width,     # draw window width
 240          $y_offset,  # y axis draw offset
 241          $min,       # minimum base position
 242          $max,       # maximum base position
 243          $entries,   # list of unsorted KISS entries
 244        ) = @_;
 245
 246     # Returns a list.
 247
 248     my ( $hist_height, $bucket_width, $factor_heigth, $factor_width, $entry, $min_bucket, $max_height, $bucket_beg, $bucket_end, $i, @buckets, $bucket, @hist, $x, $h );
 249
 250     return if $max == $min;
 251
 252     $hist_height  = 100;   # pixels
 253     $bucket_width = 5;     # pixels
 254
 255     $factor_width = ( $width / $bucket_width ) / ( $max - $min );
 256
 257     $min_bucket = 999999999;
 258     $max_height = 0;
 259
 260     foreach $entry ( @{ $entries } )
 261     {
 262         $bucket_beg = int( $entry->{ 'S_BEG' } * $factor_width );
 263         $bucket_end = int( $entry->{ 'S_END' } * $factor_width );
 264
 265         $min_bucket = Maasha::Calc::min( $min_bucket, $bucket_beg );
 266
 267         for ( $i = $bucket_beg; $i <= $bucket_end; $i++ )
 268         {
 269             $buckets[ $i ]++;
 270
 271             $max_height = Maasha::Calc::max( $max_height, $buckets[ $i ] );
 272         }
 273     }
 274
 275     if ( $max_height > 0 )
 276     {
 277         $factor_heigth = $hist_height / $max_height;
 278
 279         $x = 0;
 280
 281         for ( $i = $min_bucket; $i < @buckets; $i++ )
 282         {
 283             if ( defined $buckets[ $i ] )
 284             {
 285                 $h = sprintf( "%.0f", $buckets[ $i ] * $factor_heigth );
 286
 287                 if ( $h >= 1 )
 288                 {
 289                     push @hist, {
 290                         type       => 'line',
 291                         line_width => $bucket_width,
 292                         color      => 'green',
 293                         title      => "Features: $buckets[ $i ]",
 294                         x1         => $x,
 295                         y1         => $y_offset + $hist_height,
 296                         x2         => $x,
 297                         y2         => $y_offset + $hist_height - $h,
 298                     };
 299                 }
 300             }
 301
 302             $x += $bucket_width;
 303         }
 304     }
 305
 306     return wantarray ? @hist : \@hist;
 307 }
 308
 309
 310 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 311
 312 1;