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::Common;
  35 use Maasha::Calc;
  36 use vars qw( @ISA @EXPORT );
  37
  38 @ISA = qw( Exporter );
  39
  40
  41 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  42
  43
  44 sub track_ruler
  45 {
  46     my ( $draw_metrics,   # hashref with image draw metrics
  47          $cookie,         # browser cookie
  48        ) = @_;
  49
  50     my ( $beg, $end, $factor, $step, $i, $txt, $x, @ruler );
  51
  52     $beg = $cookie->{ 'NAV_START' };
  53     $end = $cookie->{ 'NAV_END' };
  54
  55     $factor = $draw_metrics->{ 'IMG_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 = Maasha::Calc::commify( $i ) . "|";
  69             $x   = sprintf( "%.0f", ( $i - $beg - length $txt ) * $factor );
  70
  71             if ( $x > 0 and $x + ( $draw_metrics->{ 'RULER_FONT_SIZE' } * length $txt ) < $draw_metrics->{ 'IMG_WIDTH' } )
  72             {
  73                 push @ruler, {
  74                     type      => 'text',
  75                     txt       => $txt,
  76                     font_size => $draw_metrics->{ 'RULER_FONT_SIZE' },
  77                     color     => $draw_metrics->{ 'RULER_COLOR' },
  78                     x1        => $x,
  79                     y1        => $draw_metrics->{ 'TRACK_OFFSET' },
  80                 };
  81             }
  82         }
  83     }
  84
  85     $draw_metrics->{ 'TRACK_OFFSET' } += $draw_metrics->{ 'TRACK_SPACE' };
  86
  87     return wantarray ? @ruler : \@ruler;
  88 }
  89
  90
  91 sub track_seq
  92 {
  93     my ( $draw_metrics,   # hashref with image draw metrics
  94          $cookie,         # browser cookie
  95        ) = @_;
  96
  97     my ( $file, $fh, $seq, @chars, $factor, $i, @seq_list );
  98
  99     if ( $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 <= 220 )
 100     {
 101         $file = path_seq( $cookie );
 102         $fh   = Maasha::Filesys::file_read_open( $file );
 103         $seq  = Maasha::Filesys::file_read( $fh, $cookie->{ 'NAV_START' } - 1, $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 );
 104         close $fh;
 105
 106         @chars = split //, $seq;
 107
 108         $factor = $draw_metrics->{ 'IMG_WIDTH' } / @chars;
 109
 110         for ( $i = 0; $i < @chars; $i++ ) {
 111             push @seq_list, {
 112                 type      => 'text',
 113                 txt       => $chars[ $i ],
 114                 font_size => $draw_metrics->{ 'SEQ_FONT_SIZE' },
 115                 color     => $draw_metrics->{ 'SEQ_COLOR' },
 116                 x1        => sprintf( "%.0f", $i * $factor ),
 117                 y1        => $draw_metrics->{ 'TRACK_OFFSET' },
 118             };
 119         }
 120
 121         $draw_metrics->{ 'TRACK_OFFSET' } += $draw_metrics->{ 'TRACK_SPACE' };
 122
 123         return wantarray ? @seq_list : \@seq_list;
 124     }
 125     else
 126     {
 127         return;
 128     }
 129 }
 130
 131
 132 sub track_feature
 133 {
 134     my ( $track,
 135          $draw_metrics,
 136          $cookie,
 137        ) = @_;
 138
 139     # Returns a list.
 140
 141     my ( $index, $count, $track_name, $start, $end, $entries, $features );
 142
 143     $start = $cookie->{ 'NAV_START' };
 144     $end   = $cookie->{ 'NAV_END' };
 145
 146     $index = Maasha::KISS::IO::kiss_index_retrieve( "$track/track_data.kiss.index" );
 147     $count = Maasha::KISS::IO::kiss_index_count( $index, $start, $end );
 148
 149     $track_name = ( split "/", $track )[ -1 ];
 150     $track_name =~ s/^\d+_//;
 151     $track_name =~ s/_/ /g;
 152
 153     $features = [ {
 154         type      => 'text',
 155         txt       => $track_name,
 156         font_size => $draw_metrics->{ 'SEQ_FONT_SIZE' },
 157         color     => $draw_metrics->{ 'SEQ_COLOR' },
 158         x1        => 0,
 159         y1        => $draw_metrics->{ 'TRACK_OFFSET' },
 160     } ];
 161
 162     $draw_metrics->{ 'TRACK_OFFSET' } += 10;
 163
 164     if ( $count > 5000 )
 165     {
 166         $entries  = Maasha::KISS::IO::kiss_index_get_blocks( $index, $start, $end );
 167         push @{ $features }, Maasha::KISS::Track::track_feature_histogram( $draw_metrics, $start, $end, $entries );
 168     }
 169     else
 170     {
 171         $entries  = Maasha::KISS::IO::kiss_index_get_entries( "$track/track_data.kiss", $index, $start, $end );
 172         push @{ $features }, Maasha::KISS::Track::track_feature_linear( $draw_metrics, $start, $end, $entries );
 173     }
 174
 175     return wantarray ? @{ $features } : $features;
 176 }
 177
 178
 179 sub track_feature_linear
 180 {
 181     my ( $draw_metrics,   # hashref with image draw metrics
 182          $beg,            # base window beg
 183          $end,            # base window end
 184          $entries,        # list of unsorted KISS entries
 185        ) = @_;
 186
 187     # Returns a list.
 188
 189     my ( $factor, $entry, $y_step, @ladder, $y_max, $w, $x1, $y1, $x2, $y2, @features );
 190
 191     @{ $entries } = sort { $a->{ 'S_BEG' } <=> $b->{ 'S_BEG' } or $a->{ 'S_END' } <=> $b->{ 'S_END' } } @{ $entries };
 192
 193     $factor = $draw_metrics->{ 'IMG_WIDTH' } / ( $end - $beg );
 194     $y_step = 0;
 195     $y_max  = 0;
 196
 197     foreach $entry ( @{ $entries } )
 198     {
 199         $w = sprintf( "%.0f", ( $entry->{ 'S_END' } - $entry->{ 'S_BEG' } + 1 ) * $factor );
 200
 201         if ( $w >= 1 )
 202         {
 203             $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } - $beg ) * $factor );
 204
 205             for ( $y_step = 0; $y_step < @ladder; $y_step++ ) {
 206                 last if $x1 >= $ladder[ $y_step ] + 1;
 207             }
 208
 209             $y1 = $draw_metrics->{ 'TRACK_OFFSET' } + ( $draw_metrics->{ 'FEAT_WIDTH' } * $y_step );
 210
 211             push @features, {
 212                 type       => 'rect',
 213                 line_width => $draw_metrics->{ 'FEAT_WIDTH' },
 214                 color      => $draw_metrics->{ 'FEAT_COLOR' },
 215                 title      => "Q_ID: $entry->{ 'Q_ID' } S_BEG: $entry->{ 'S_BEG' } S_END: $entry->{ 'S_END' } STRAND: $entry->{ 'STRAND' }",
 216                 id         => $entry->{ 'Q_ID' },
 217                 x1         => $x1,
 218                 y1         => $y1,
 219                 x2         => $x1 + $w,
 220                 y2         => $y1 + $draw_metrics->{ 'FEAT_WIDTH' },
 221             };
 222
 223             $y_max = Maasha::Calc::max( $y_max, $y_step * $draw_metrics->{ 'FEAT_WIDTH' } );
 224
 225             push @features, feature_align( $entry, $beg, $y1, $factor, $draw_metrics->{ 'FEAT_WIDTH' } ) if $entry->{ 'ALIGN' } ne '.';
 226
 227             $ladder[ $y_step ] = $x1 + $w;
 228         }
 229     }
 230
 231     $draw_metrics->{ 'TRACK_OFFSET' } += $y_max + $draw_metrics->{ 'TRACK_SPACE' };
 232
 233     return wantarray ? @features : \@features;
 234 }
 235
 236
 237 sub feature_align
 238 {
 239     # 17:A>T
 240
 241     my ( $entry,         # Partial KISS entry
 242          $beg,           # base window beg
 243          $y_offset,      # y axis draw offset
 244          $factor,        # scale factor
 245          $feat_height,   # hight of feature in pixels
 246        ) = @_;
 247
 248     # Returns a list.
 249
 250     my ( $w, $align, $pos, $nt_before, $nt_after, $x1, @features );
 251
 252     $w = sprintf( "%.0f", 1 * $factor );
 253
 254     if ( $w >= 1 )
 255     {
 256         foreach $align ( split /,/, $entry->{ 'ALIGN' } )
 257         {
 258             if ( $align =~ /(\d+):([ATCGN-])>([ATCGN-])/ )
 259             {
 260                 $pos       = $1;
 261                 $nt_before = $2;
 262                 $nt_after  = $3;
 263             }
 264             else
 265             {
 266                 Maasha::Common::error( qq(BAD align descriptor: "$align") );
 267             }
 268
 269             $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } + $pos - $beg ) * $factor );
 270
 271             push @features, {
 272                 type       => 'rect',
 273                 line_width => $feat_height,
 274                 color      => [ 1, 0, 0 ],
 275                 title      => $align,
 276                 x1         => $x1,
 277                 y1         => $y_offset,
 278                 x2         => $x1 + $w,
 279                 y2         => $y_offset + $feat_height,
 280             };
 281
 282             if ( $w > $feat_height )
 283             {
 284                 push @features, {
 285                     type       => 'text',
 286                     font_size  => $feat_height + 2,
 287                     color      => [ 0, 0, 0 ],
 288                     txt        => $nt_after,
 289                     x1         => $x1 + sprintf( "%.0f", ( $w / 2 ) ) - $feat_height / 2,
 290                     y1         => $y_offset + $feat_height,
 291                 };
 292             }
 293         }
 294     }
 295
 296     return wantarray ? @features : \@features;
 297 }
 298
 299
 300 sub track_feature_histogram
 301 {
 302     my ( $draw_metrics,   # hashref with image draw metrics
 303          $min,            # minimum base position
 304          $max,            # maximum base position
 305          $blocks,         # list of blocks
 306        ) = @_;
 307
 308     # Returns a list.
 309
 310     my ( $hist_height, $bucket_width, $bucket_count, $min_bucket, $factor, $factor_heigth, $max_height, $block, $bucket_beg, $bucket_end, $i, @buckets, $h, $x, @hist );
 311
 312     return if $max <= $min;
 313
 314     $hist_height  = 100;   # pixels
 315     $bucket_width = 5;
 316     $bucket_count = $draw_metrics->{ 'IMG_WIDTH' } / $bucket_width;
 317     $factor       = ( $draw_metrics->{ 'IMG_WIDTH' } / $bucket_width ) / ( $max - $min + 1 );
 318
 319     $min_bucket = 999999999;
 320     $max_height = 0;
 321
 322     foreach $block ( @{ $blocks } )
 323     {
 324         $bucket_beg = int( $block->{ 'BEG' } * $factor );
 325         $bucket_end = int( $block->{ 'END' } * $factor );
 326
 327         $min_bucket = Maasha::Calc::min( $min_bucket, $bucket_beg );
 328
 329         for ( $i = $bucket_beg; $i <= $bucket_end; $i++ )
 330         {
 331             $buckets[ $i ] += $block->{ 'COUNT' };
 332
 333             $max_height = Maasha::Calc::max( $max_height, $buckets[ $i ] );
 334         }
 335     }
 336
 337     if ( $max_height > 0 )
 338     {
 339         $factor_heigth = $hist_height / $max_height;
 340
 341         $x = 0;
 342
 343         for ( $i = $min_bucket; $i < @buckets; $i++ )
 344         {
 345             if ( defined $buckets[ $i ] )
 346             {
 347                 $h = sprintf( "%.0f", $buckets[ $i ] * $factor_heigth );
 348
 349                 if ( $h >= 1 )
 350                 {
 351                     push @hist, {
 352                         type       => 'line',
 353                         line_width => $bucket_width,
 354                         color      => $draw_metrics->{ 'FEAT_COLOR' },
 355                         title      => "Features: $buckets[ $i ]",
 356                         x1         => $x,
 357                         y1         => $draw_metrics->{ 'TRACK_OFFSET' } + $hist_height,
 358                         x2         => $x,
 359                         y2         => $draw_metrics->{ 'TRACK_OFFSET' } + $hist_height - $h,
 360                     };
 361                 }
 362             }
 363
 364             $x += $bucket_width;
 365         }
 366     }
 367
 368     $draw_metrics->{ 'TRACK_OFFSET' } += $hist_height + $draw_metrics->{ 'TRACK_SPACE' };
 369
 370     return wantarray ? @hist : \@hist;
 371 }
 372
 373
 374 sub path_seq
 375 {
 376     my ( $cookie,
 377        ) = @_;
 378
 379     # Returns a string.
 380
 381     my ( $path );
 382
 383     die qq(ERROR: no USER in cookie.\n)     if not $cookie->{ 'USER' };
 384     die qq(ERROR: no CLADE in cookie.\n)    if not $cookie->{ 'CLADE' };
 385     die qq(ERROR: no GENOME in cookie.\n)   if not $cookie->{ 'GENOME' };
 386     die qq(ERROR: no ASSEMBLY in cookie.\n) if not $cookie->{ 'ASSEMBLY' };
 387     die qq(ERROR: no CONTIG in cookie.\n)   if not $cookie->{ 'CONTIG' };
 388
 389     $path = join( "/",
 390         $cookie->{ 'DATA_DIR' },
 391         "Users",
 392         $cookie->{ 'USER' },
 393         $cookie->{ 'CLADE' },
 394         $cookie->{ 'GENOME' },
 395         $cookie->{ 'ASSEMBLY' },
 396         $cookie->{ 'CONTIG' },
 397         "Sequence",
 398         "sequence.txt"
 399     );
 400
 401     die qq(ERROR: no such file: "$path".\n) if not -e $path;
 402
 403     return $path;
 404 }
 405
 406
 407 sub path_tracks
 408 {
 409     my ( $cookie,
 410        ) = @_;
 411
 412     # Returns a list.
 413     #
 414     my ( $path, @tracks );
 415
 416     die qq(ERROR: no USER in cookie.\n)     if not $cookie->{ 'USER' };
 417     die qq(ERROR: no CLADE in cookie.\n)    if not $cookie->{ 'CLADE' };
 418     die qq(ERROR: no GENOME in cookie.\n)   if not $cookie->{ 'GENOME' };
 419     die qq(ERROR: no ASSEMBLY in cookie.\n) if not $cookie->{ 'ASSEMBLY' };
 420     die qq(ERROR: no CONTIG in cookie.\n)   if not $cookie->{ 'CONTIG' };
 421
 422     $path = join( "/",
 423         $cookie->{ 'DATA_DIR' },
 424         "Users",
 425         $cookie->{ 'USER' },
 426         $cookie->{ 'CLADE' },
 427         $cookie->{ 'GENOME' },
 428         $cookie->{ 'ASSEMBLY' },
 429         $cookie->{ 'CONTIG' },
 430         "Tracks",
 431     );
 432
 433     if ( -d $path )
 434     {
 435         @tracks = Maasha::Filesys::ls_dirs( $path );
 436
 437         @tracks = grep { $_ !~ /\/\.\.?$/ } @tracks;
 438
 439         return wantarray ? @tracks : \@tracks;
 440     }
 441     else
 442     {
 443         return wantarray ? () : [];
 444     }
 445 }
 446
 447 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 448
 449 1;
 450