code_perl/Maasha/BGB/Track.pm

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