code_perl/Maasha/BBrowser/Track.pm

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