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        ) = @_;
  50
  51     my ( $factor, $step, $i, $txt, $x, @ruler );
  52
  53     $factor = $width / ( $end - $beg );
  54
  55     $step = 10;
  56
  57     while ( ( $end - $beg ) / $step > 20 )
  58     {
  59         $step *= 5;
  60     }
  61
  62     for ( $i = $beg; $i < $end; $i++ )
  63     {
  64         if ( ( $i % $step ) == 0 )
  65         {
  66             $txt = "$i|";
  67             $x   = sprintf( "%.0f", ( $i - $beg - length $txt ) * $factor );
  68
  69             push @ruler, { txt => $txt, x => $x, y => $y_offset };
  70         }
  71     }
  72
  73     return wantarray ? @ruler : \@ruler;
  74 }
  75
  76
  77 sub track_seq
  78 {
  79     my ( $width,     # draw window width
  80          $y_offset,  # y axis draw offset
  81          $seq,       # sequence to draw
  82        ) = @_;
  83
  84     my ( @chars, $factor, $i, @seq_list );
  85
  86     @chars = split //, $seq;
  87
  88     $factor = $width / @chars;
  89
  90     for ( $i = 0; $i < @chars; $i++ ) {
  91         push @seq_list, { txt => $chars[ $i ], x => sprintf( "%.0f", $i * $factor ), y => $y_offset };
  92     }
  93
  94     return wantarray ? @seq_list : \@seq_list;
  95 }
  96
  97
  98 sub track_feature
  99 {
 100     my ( $width,     # draw window width
 101          $y_offset,  # y axis draw offset
 102          $beg,       # base window beg
 103          $end,       # base window end
 104          $entries,   # list of unsorted KISS entries
 105        ) = @_;
 106
 107     # Returns a list.
 108
 109     my ( $feat_height, $factor, $entry, $y_step, @ladder, $w, $x1, $y1, $x2, $y2, @features );
 110
 111     @{ $entries } = sort { $a->{ 'S_BEG' } <=> $b->{ 'S_BEG' } or $a->{ 'S_END' } <=> $b->{ 'S_END' } } @{ $entries };
 112
 113     $feat_height = 5;
 114     $factor      = $width / ( $end - $beg );
 115     $y_step      = 0;
 116
 117     foreach $entry ( @{ $entries } )
 118     {
 119         $w = sprintf( "%.0f", ( $entry->{ 'S_END' } - $entry->{ 'S_BEG' } + 1 ) * $factor );
 120
 121         if ( $w >= 1 )
 122         {
 123             $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } - $beg ) * $factor );
 124
 125             for ( $y_step = 0; $y_step < @ladder; $y_step++ )
 126             {
 127                 last if $x1 >= $ladder[ $y_step ] + 1;
 128             }
 129
 130             $y1 = $y_offset + ( $feat_height * $y_step );
 131
 132             push @features, {
 133                 type       => 'line',
 134                 line_width => $feat_height,
 135                 color      => 'green',
 136                 x1         => $x1,
 137                 y1         => $y1,
 138                 x2         => $x1 + $w,
 139                 y2         => $y1,
 140             };
 141
 142             push @features, feature_align( $entry, $beg, $y1, $factor, $feat_height ) if defined $entry->{ 'ALIGN' };
 143
 144             $ladder[ $y_step ] = $x1 + $w;
 145         }
 146     }
 147
 148     return wantarray ? @features : \@features;
 149 }
 150
 151
 152 sub feature_align
 153 {
 154     # 17:A>T
 155
 156     my ( $entry,         # Partial KISS entry
 157          $beg,           # base window beg
 158          $y_offset,      # y axis draw offset
 159          $factor,        # scale factor
 160          $feat_height,   # hight of feature in pixels
 161        ) = @_;
 162
 163     # Returns a list.
 164
 165     my ( $w, $align, $pos, $nt_before, $nt_after, $x1, @features );
 166
 167     $w = sprintf( "%.0f", 1 * $factor );
 168
 169     if ( $w >= 1 )
 170     {
 171         foreach $align ( split /,/, $entry->{ 'ALIGN' } )
 172         {
 173             if ( $align =~ /(\d+):(\w)>(\w)/ )
 174             {
 175                 $pos       = $1;
 176                 $nt_before = $2;
 177                 $nt_after  = $3;
 178             }
 179             else
 180             {
 181                 die;
 182             }
 183
 184             $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } + $pos - $beg ) * $factor );
 185
 186             push @features, {
 187                 type       => 'line',
 188                 line_width => $feat_height,
 189                 color      => 'red',
 190                 x1         => $x1,
 191                 y1         => $y_offset,
 192                 x2         => $x1 + $w,
 193                 y2         => $y_offset,
 194             };
 195
 196             if ( $w > 5 )
 197             {
 198                 push @features, {
 199                     type       => 'text',
 200                     font_size  => $feat_height,
 201                     color      => 'black',
 202                     txt        => $nt_after,
 203                     x1         => $x1 + sprintf( "%.0f", ( $w / 2 ) ) - $feat_height / 2,
 204                     y1         => $y_offset,
 205                 };
 206             }
 207         }
 208     }
 209
 210     return wantarray ? @features : \@features;
 211 }
 212
 213
 214 sub track_histogram
 215 {
 216     my ( $width,     # draw window width
 217          $y_offset,  # y axis draw offset
 218          $min,       # minimum base position
 219          $max,       # maximum base position
 220          $entries,   # list of unsorted KISS entries
 221        ) = @_;
 222
 223     # Returns a list.
 224
 225     my ( $hist_height, $bucket_width, $factor_heigth, $factor_width, $entry, $min_bucket, $max_height, $bucket_beg, $bucket_end, $i, @buckets, $bucket, @hist, $x, $h );
 226
 227     return if $max == $min;
 228
 229     $hist_height  = 100;   # pixels
 230     $bucket_width = 5;     # pixels
 231
 232     $factor_width = ( $width / $bucket_width ) / ( $max - $min );
 233
 234     $min_bucket = 999999999;
 235     $max_height = 0;
 236
 237     foreach $entry ( @{ $entries } )
 238     {
 239         $bucket_beg = int( $entry->{ 'S_BEG' } * $factor_width );
 240         $bucket_end = int( $entry->{ 'S_END' } * $factor_width );
 241
 242         $min_bucket = Maasha::Calc::min( $min_bucket, $bucket_beg );
 243
 244         for ( $i = $bucket_beg; $i <= $bucket_end; $i++ )
 245         {
 246             $buckets[ $i ]++;
 247
 248             $max_height = Maasha::Calc::max( $max_height, $buckets[ $i ] );
 249         }
 250     }
 251
 252     if ( $max_height > 0 )
 253     {
 254         $factor_heigth = $hist_height / $max_height;
 255
 256         $x = 0;
 257
 258         for ( $i = $min_bucket; $i < @buckets; $i++ )
 259         {
 260             if ( defined $buckets[ $i ] )
 261             {
 262                 $h = sprintf( "%.0f", $buckets[ $i ] * $factor_heigth );
 263
 264                 if ( $h >= 1 )
 265                 {
 266                     push @hist, {
 267                         type       => 'line',
 268                         line_width => $bucket_width,
 269                         color      => 'green',
 270                         x1         => $x,
 271                         y1         => $y_offset + $hist_height,
 272                         x2         => $x,
 273                         y2         => $y_offset + $hist_height - $h,
 274                     };
 275                 }
 276             }
 277
 278             $x += $bucket_width;
 279         }
 280     }
 281
 282     return wantarray ? @hist : \@hist;
 283 }
 284
 285
 286 sub bucket_round
 287 {
 288     my ( $num,
 289          $bucket_size,
 290        ) = @_;
 291
 292     my ( $div, $int );
 293
 294     $div = $num / $bucket_size;
 295     $int = int $div;
 296
 297     if ( $div - $int >= 0.5 ) {
 298         return $bucket_size * ( $int + 1 );
 299     } else {
 300         return $bucket_size * $int;
 301     }
 302 }
 303
 304
 305 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 306
 307 1;
 308
 309