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 use Maasha::BGB::Wiggle;
  41
  42 use vars qw( @ISA @EXPORT );
  43
  44 @ISA = qw( Exporter );
  45
  46 use constant {
  47     S_ID             => 0,
  48     S_BEG            => 1,
  49     S_END            => 2,
  50     Q_ID             => 3,
  51     SCORE            => 4,
  52     STRAND           => 5,
  53     HITS             => 6,
  54     ALIGN            => 7,
  55     BLOCK_COUNT      => 8,
  56     BLOCK_BEGS       => 9,
  57     BLOCK_LENS       => 10,
  58     BLOCK_TYPE       => 11,
  59 };
  60
  61 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  62
  63
  64 sub track_grid
  65 {
  66     # Martin A. Hansen, March 2010.
  67
  68     # Create a grid of vertical lines for the browser image.
  69
  70     my ( $cookie,   # browser cookie
  71        ) = @_;
  72
  73     # Returns a list.
  74
  75     my ( @grid, $i );
  76
  77     for ( $i = 0; $i < $cookie->{ 'IMG_WIDTH' }; $i += 20 )
  78     {
  79         push @grid, {
  80             type       => 'grid',
  81             line_width => 1,
  82             color      => [ 0.82, 0.89, 1 ],
  83             x1         => $i,
  84             y1         => 0,
  85             x2         => $i,
  86             y2         => $cookie->{ 'TRACK_OFFSET' },
  87         };
  88     }
  89
  90     return wantarray ? @grid : \@grid;
  91 }
  92
  93
  94 sub track_ruler
  95 {
  96     # Martin A. Hansen, November 2009.
  97
  98     # Create a track with a ruler of tics and positions for
  99     # the browser window.
 100
 101     my ( $cookie,   # browser cookie
 102        ) = @_;
 103
 104     # Returns a list.
 105
 106     my ( $beg, $end, $factor, $step, $i, $txt, $x, @ruler );
 107
 108     $beg    = $cookie->{ 'NAV_START' };
 109     $end    = $cookie->{ 'NAV_END' };
 110     $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg );
 111
 112     $step = 10;
 113
 114     while ( ( $end - $beg ) / $step > 20 ) {
 115         $step *= 5;
 116     }
 117
 118     for ( $i = $beg; $i < $end; $i++ )
 119     {
 120         if ( ( $i % $step ) == 0 )
 121         {
 122             $txt = "|" . Maasha::Calc::commify( $i );
 123             $x   = sprintf( "%.0f", ( ( $i - $beg ) * $factor ) + 2 );
 124
 125             if ( $x > 0 and $x + ( $cookie->{ 'RULER_FONT_SIZE' } * length $txt ) < $cookie->{ 'IMG_WIDTH' } )
 126             {
 127                 push @ruler, {
 128                     type      => 'text',
 129                     txt       => $txt,
 130                     font_size => $cookie->{ 'RULER_FONT_SIZE' },
 131                     color     => $cookie->{ 'RULER_COLOR' },
 132                     x1        => $x,
 133                     y1        => $cookie->{ 'TRACK_OFFSET' },
 134                 };
 135             }
 136         }
 137     }
 138
 139     $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'TRACK_SPACE' };
 140
 141     return wantarray ? @ruler : \@ruler;
 142 }
 143
 144
 145 sub track_seq
 146 {
 147     # Martin A. Hansen, November 2009.
 148
 149     # Create a sequence track by extracting the appropriate
 150     # stretch of sequence from the sequence file.
 151
 152     my ( $cookie,   # browser cookie
 153        ) = @_;
 154
 155     # Returns a list.
 156
 157     my ( $file, $fh, $seq, @chars, $factor, $x_offset, $i, @seq_list );
 158
 159     if ( $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 <= 220 )  # only add sequence if less than or equal to 220.
 160     {
 161         $file = path_seq( $cookie );
 162         $fh   = Maasha::Filesys::file_read_open( $file );
 163         $seq  = Maasha::Filesys::file_read( $fh, $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 );
 164         close $fh;
 165
 166         @chars = split //, $seq;
 167
 168         $factor = $cookie->{ 'IMG_WIDTH' } / @chars;
 169
 170         $x_offset = sprintf( "%.0f", ( $factor / 2 ) - ( $cookie->{ 'SEQ_FONT_SIZE' } / 2 ) );
 171         $x_offset = 0 if $x_offset < 0;
 172
 173         for ( $i = 0; $i < @chars; $i++ )
 174         {
 175             push @seq_list, {
 176                 type      => 'text',
 177                 txt       => $chars[ $i ],
 178                 font_size => $cookie->{ 'SEQ_FONT_SIZE' },
 179                 color     => $cookie->{ 'SEQ_COLOR' },
 180                 x1        => sprintf( "%.0f", $x_offset + $i * $factor ),
 181                 y1        => $cookie->{ 'TRACK_OFFSET' },
 182             };
 183         }
 184
 185         $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'TRACK_SPACE' };
 186
 187         return wantarray ? @seq_list : \@seq_list;
 188     }
 189     else
 190     {
 191         return;
 192     }
 193 }
 194
 195
 196 sub track_feature
 197 {
 198     # Martin A. Hansen, November 2009.
 199
 200     my ( $track,    # path to track data
 201          $cookie,   # cookie hash
 202        ) = @_;
 203
 204     # Returns a list.
 205
 206     my ( $data_wig, $data_kiss, $track_pretty, $track_name, $features, $color );
 207
 208     $track_name = ( split "/", $track )[ -1 ];
 209
 210     $track_pretty = $track_name;
 211     $track_pretty =~ s/^\d+_//;
 212     $track_pretty =~ s/_/ /g;
 213
 214     if ( track_hide( $cookie, $track_name ) ) {
 215         $color = [ 0.6, 0.6, 0.6 ];
 216     } else {
 217         $color = $cookie->{ 'SEQ_COLOR' };
 218     }
 219
 220     push @{ $features }, {
 221         type      => 'track_name',
 222         track     => $track_name,
 223         txt       => $track_pretty,
 224         font_size => $cookie->{ 'SEQ_FONT_SIZE' },
 225         color     => $color,
 226         x1        => 0,
 227         y1        => $cookie->{ 'TRACK_OFFSET' },
 228     };
 229
 230     $cookie->{ 'TRACK_OFFSET' } += 10;
 231
 232     if ( not track_hide( $cookie, $track_name ) )
 233     {
 234         if ( -f "$track/track_data.wig" )
 235         {
 236             $data_wig = Maasha::BGB::Wiggle::wiggle_retrieve( "$track/track_data.wig", $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' } );
 237
 238             push @{ $features }, track_wiggle( $cookie, $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' }, $data_wig );
 239         }
 240         elsif ( -f "$track/track_data.kiss" )
 241         {
 242             $data_kiss = Maasha::KISS::kiss_retrieve( "$track/track_data.kiss", $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' } );
 243
 244             push @{ $features }, track_linear( $cookie, $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' }, $data_kiss );
 245         }
 246         else
 247         {
 248             Maasha::Common::error( "Unknown track data type" );
 249         }
 250     }
 251
 252     return wantarray ? @{ $features } : $features;
 253 }
 254
 255
 256 sub track_wiggle
 257 {
 258     # Martin A. Hansen, February 2010.
 259
 260     # Create a wiggle track.
 261
 262     my ( $cookie,    # hashref with image draw metrics
 263          $beg,       # base window beg
 264          $end,       # base window end
 265          $vals,      # wiggle values
 266        ) = @_;
 267
 268     # Returns a list.
 269
 270     my ( $i, $max_val, $min_val, $factor, $factor_height, $x1, $y1, $x2, $y2, $block_max, $mean, @features );
 271
 272     $cookie->{ 'TRACK_OFFSET' } += 10;
 273
 274     $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg );
 275
 276     ( $min_val, $max_val ) = Maasha::Calc::minmax( $vals );
 277
 278     if ( $max_val == 0 ) {
 279         $factor_height = $cookie->{ 'WIGGLE_HEIGHT' } / 1;
 280     } else {
 281         $factor_height = $cookie->{ 'WIGGLE_HEIGHT' } / $max_val;
 282     }
 283
 284     $block_max = 0;
 285
 286     $x1 = 0;
 287     $y1 = $cookie->{ 'TRACK_OFFSET' } + $cookie->{ 'WIGGLE_HEIGHT' };
 288
 289     for ( $i = 0; $i < scalar @{ $vals }; $i++ )
 290     {
 291         $block_max = Maasha::Calc::max( $block_max, $vals->[ $i ] );
 292
 293         $x2 = int( $i * $factor );
 294
 295         if ( $x2 > $x1 )
 296         {
 297             $y2 = $cookie->{ 'TRACK_OFFSET' } + $cookie->{ 'WIGGLE_HEIGHT' } - sprintf( "%.0f", $block_max * $factor_height );
 298
 299             push @features, {
 300                 type       => 'wiggle',
 301                 color      => $cookie->{ 'FEAT_COLOR' },
 302                 line_width => 1,
 303                 x1         => $x1,
 304                 y1         => $y1,
 305                 x2         => $x2,
 306                 y2         => $y2,
 307             };
 308
 309             $x1 = $x2;
 310             $y1 = $y2;
 311
 312             $block_max = 0;
 313         }
 314     }
 315
 316     $y2 = $cookie->{ 'TRACK_OFFSET' } + $cookie->{ 'WIGGLE_HEIGHT' };
 317
 318     push @features, {
 319         type       => 'wiggle',
 320         color      => $cookie->{ 'FEAT_COLOR' },
 321         line_width => 1,
 322         x1         => $x1,
 323         y1         => $y1,
 324         x2         => $x2,
 325         y2         => $y2,
 326     };
 327
 328     unshift @features, {
 329         type      => 'text',
 330         txt       => "  min: " . Maasha::Calc::commify( $min_val ) . " max: " . Maasha::Calc::commify( $max_val ),
 331         font_size => $cookie->{ 'SEQ_FONT_SIZE' } - 2,
 332         color     => $cookie->{ 'SEQ_COLOR' },
 333         x1        => 0,
 334         y1        => $cookie->{ 'TRACK_OFFSET' } - 5,
 335     };
 336
 337     $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'WIGGLE_HEIGHT' } + $cookie->{ 'TRACK_SPACE' };
 338
 339     return wantarray ? @features : \@features;
 340 }
 341
 342
 343 sub track_linear
 344 {
 345     # Martin A. Hansen, November 2009.
 346
 347     # Create a linear feature track where the granularity depends
 348     # on the lenght of the features and the browser window width.
 349
 350     my ( $cookie,    # hashref with image draw metrics
 351          $beg,       # base window beg
 352          $end,       # base window end
 353          $entries,   # list of unsorted KISS entries
 354        ) = @_;
 355
 356     # Returns a list.
 357
 358     my ( $factor, $entry, $y_step, @ladder, $y_max, $w, $x1, $y1, $x2, $y2, $feature, @features );
 359
 360     $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg );
 361     $y_step = 0;
 362     $y_max  = 0;
 363
 364     foreach $entry ( @{ $entries } )
 365     {
 366         $w = sprintf( "%.0f", ( $entry->[ S_END ] - $entry->[ S_BEG ] + 1 ) * $factor );
 367
 368         if ( $w >= 1 )
 369         {
 370             $x1 = sprintf( "%.0f", ( $entry->[ S_BEG ] - $beg ) * $factor );
 371             $x2 = $x1 + $w;
 372
 373             $x1 = 0 if $x1 < 0;
 374             $x2 = $cookie->{ 'IMG_WIDTH' } if $x2 > $cookie->{ 'IMG_WIDTH' };
 375
 376             for ( $y_step = 0; $y_step < @ladder; $y_step++ ) {
 377                 last if $x1 >= $ladder[ $y_step ] + 1;
 378             }
 379
 380             $y1 = $cookie->{ 'TRACK_OFFSET' } + ( ( 1.1 + $cookie->{ 'FEAT_WIDTH' } ) * $y_step );
 381             $y2 = $y1 + $cookie->{ 'FEAT_WIDTH' };
 382
 383             $feature = {
 384                 line_width => $cookie->{ 'FEAT_WIDTH' },
 385                 color      => $cookie->{ 'FEAT_COLOR' },
 386                 title      => "Q_ID: $entry->[ Q_ID ] S_BEG: $entry->[ S_BEG ] S_END: $entry->[ S_END ]",
 387                 q_id       => $entry->[ Q_ID ],
 388                 s_beg      => $entry->[ S_BEG ],
 389                 s_end      => $entry->[ S_END ],
 390                 strand     => $entry->[ STRAND ],
 391                 x1         => $x1,
 392                 y1         => $y1,
 393                 x2         => $x2,
 394                 y2         => $y2,
 395             };
 396
 397             if ( $entry->[ STRAND ] eq '+' or $entry->[ STRAND ] eq '-' ) {
 398                 $feature->{ 'type' } = 'arrow';
 399             } else {
 400                 $feature->{ 'type' } = 'rect';
 401             }
 402
 403             push @features, $feature;
 404
 405             $y_max = Maasha::Calc::max( $y_max, $y_step * ( 1.1 + $cookie->{ 'FEAT_WIDTH' } ) );
 406
 407             push @features, feature_align( $entry, $beg, $y1, $factor, $cookie->{ 'FEAT_WIDTH' } ) if $entry->[ ALIGN ] ne '.';
 408
 409             $ladder[ $y_step ] = $x1 + $w;
 410         }
 411     }
 412
 413     $cookie->{ 'TRACK_OFFSET' } += $y_max + $cookie->{ 'TRACK_SPACE' };
 414
 415     return wantarray ? @features : \@features;
 416 }
 417
 418
 419 sub feature_align
 420 {
 421     # Martin A. Hansen, November 2009.
 422
 423     # Add to feature track alignment info if the granularity is
 424     # sufficient.
 425     # TODO: The printing of chars is imprecise.
 426
 427     my ( $entry,         # Partial KISS entry
 428          $beg,           # base window beg
 429          $y_offset,      # y axis draw offset
 430          $factor,        # scale factor
 431          $feat_height,   # hight of feature in pixels
 432        ) = @_;
 433
 434     # Returns a list.
 435
 436     my ( $w, $align, $pos, $nt_before, $nt_after, $x1, @features );
 437
 438     $w = sprintf( "%.0f", 1 * $factor );
 439
 440     if ( $w >= 1 )
 441     {
 442         foreach $align ( split /,/, $entry->[ ALIGN ] )
 443         {
 444             if ( $align =~ /(\d+):([ATCGN-])>([ATCGN-])/ )
 445             {
 446                 $pos       = $1;
 447                 $nt_before = $2;
 448                 $nt_after  = $3;
 449             }
 450             else
 451             {
 452                 Maasha::Common::error( qq(BAD align descriptor: "$align") );
 453             }
 454
 455             $x1 = sprintf( "%.0f", ( $entry->[ S_BEG ] + $pos - $beg ) * $factor );
 456
 457             push @features, {
 458                 type       => 'rect',
 459                 line_width => $feat_height,
 460                 color      => [ 1, 0, 0 ],
 461                 title      => $align,
 462                 x1         => $x1,
 463                 y1         => $y_offset,
 464                 x2         => $x1 + $w,
 465                 y2         => $y_offset + $feat_height,
 466             };
 467
 468             if ( $w > $feat_height )
 469             {
 470                 push @features, {
 471                     type       => 'text',
 472                     font_size  => $feat_height + 2,
 473                     color      => [ 0, 0, 0 ],
 474                     txt        => $nt_after,
 475                     x1         => $x1 + sprintf( "%.0f", ( $w / 2 ) ) - $feat_height / 2,
 476                     y1         => $y_offset + $feat_height,
 477                 };
 478             }
 479         }
 480     }
 481
 482     return wantarray ? @features : \@features;
 483 }
 484
 485
 486 sub track_feature_histogram
 487 {
 488     # Martin A. Hansen, November 2009.
 489
 490     # Create a feature track as a histogram using information
 491     # from the index only thus avoiding to load features from the
 492     # file.
 493
 494     my ( $cookie,   # hashref with image draw metrics
 495          $min,      # minimum base position
 496          $max,      # maximum base position
 497          $blocks,   # list of blocks
 498        ) = @_;
 499
 500     # Returns a list.
 501
 502     my ( $hist_height, $bucket_width, $bucket_count, $min_bucket, $factor, $factor_heigth, $max_height, $block, $bucket_beg, $bucket_end, $i, @buckets, $h, $x, @hist );
 503
 504     return if $max <= $min;
 505
 506     $hist_height  = 100;   # pixels
 507     $bucket_width = 5;
 508     $bucket_count = $cookie->{ 'IMG_WIDTH' } / $bucket_width;
 509     $factor       = ( $cookie->{ 'IMG_WIDTH' } / $bucket_width ) / ( $max - $min );
 510
 511     $min_bucket = 999999999;
 512     $max_height = 0;
 513
 514     foreach $block ( @{ $blocks } )
 515     {
 516         $bucket_beg = int( $block->{ 'BEG' } * $factor );
 517         $bucket_end = int( $block->{ 'END' } * $factor );
 518
 519         $min_bucket = Maasha::Calc::min( $min_bucket, $bucket_beg );
 520
 521         for ( $i = $bucket_beg; $i < $bucket_end; $i++ )
 522         {
 523             $buckets[ $i ] += $block->{ 'COUNT' };
 524
 525             $max_height = Maasha::Calc::max( $max_height, $buckets[ $i ] );
 526         }
 527     }
 528
 529     if ( $max_height > 0 )
 530     {
 531         $factor_heigth = $hist_height / $max_height;
 532
 533         $x = 0;
 534
 535         for ( $i = $min_bucket; $i < @buckets; $i++ )
 536         {
 537             if ( defined $buckets[ $i ] )
 538             {
 539                 $h = sprintf( "%.0f", $buckets[ $i ] * $factor_heigth );
 540
 541                 if ( $h >= 1 )
 542                 {
 543                     push @hist, {
 544                         type       => 'line',
 545                         line_width => $bucket_width,
 546                         color      => $cookie->{ 'FEAT_COLOR' },
 547                         title      => "Features: $buckets[ $i ]",
 548                         x1         => $x,
 549                         y1         => $cookie->{ 'TRACK_OFFSET' } + $hist_height,
 550                         x2         => $x,
 551                         y2         => $cookie->{ 'TRACK_OFFSET' } + $hist_height - $h,
 552                     };
 553                 }
 554             }
 555
 556             $x += $bucket_width;
 557         }
 558     }
 559
 560     $cookie->{ 'TRACK_OFFSET' } += $hist_height + $cookie->{ 'TRACK_SPACE' };
 561
 562     return wantarray ? @hist : \@hist;
 563 }
 564
 565
 566 sub dna_get
 567 {
 568     # Martin A. Hansen, November 2009.
 569
 570     # Returns the sequence from the contig in the beg/end interval
 571     # contained in the cookie.
 572
 573     my ( $cookie,   # cookie hash
 574        ) = @_;
 575
 576     # Returns a string.
 577
 578     my ( $path, $fh, $beg, $end, $len, $dna );
 579
 580     $path = path_seq( $cookie );
 581
 582     $beg = $cookie->{ 'S_BEG' };
 583     $end = $cookie->{ 'S_END' };
 584     $beg =~ tr/,//d;
 585     $end =~ tr/,//d;
 586     $len = $end - $beg + 1;
 587
 588
 589     $fh = Maasha::Filesys::file_read_open( $path );
 590
 591     $dna = Maasha::Filesys::file_read( $fh, $beg, $len );
 592
 593     $dna = Maasha::Seq::dna_revcomp( $dna ) if $cookie->{ 'STRAND' } eq '-';
 594
 595     Maasha::Seq::wrap( \$dna, 100 );
 596
 597     close $fh;
 598
 599     return $dna;
 600 }
 601
 602
 603 sub path_seq
 604 {
 605     # Martin A. Hansen, November 2009.
 606
 607     # Returns the path to the sequence file for a specified
 608     # contig as written in the cookie.
 609
 610     my ( $cookie,   # cookie hash
 611        ) = @_;
 612
 613     # Returns a string.
 614
 615     my ( $path );
 616
 617     die qq(ERROR: no USER in cookie.\n)     if not $cookie->{ 'USER' };
 618     die qq(ERROR: no CLADE in cookie.\n)    if not $cookie->{ 'CLADE' };
 619     die qq(ERROR: no GENOME in cookie.\n)   if not $cookie->{ 'GENOME' };
 620     die qq(ERROR: no ASSEMBLY in cookie.\n) if not $cookie->{ 'ASSEMBLY' };
 621     die qq(ERROR: no CONTIG in cookie.\n)   if not $cookie->{ 'CONTIG' };
 622
 623     $path = join( "/",
 624         $cookie->{ 'DATA_DIR' },
 625         "Users",
 626         $cookie->{ 'USER' },
 627         $cookie->{ 'CLADE' },
 628         $cookie->{ 'GENOME' },
 629         $cookie->{ 'ASSEMBLY' },
 630         $cookie->{ 'CONTIG' },
 631         "Sequence",
 632         "sequence.txt"
 633     );
 634
 635     die qq(ERROR: no such file: "$path".\n) if not -e $path;
 636
 637     return $path;
 638 }
 639
 640
 641 sub search_tracks
 642 {
 643     # Martin A. Hansen, December 2009.
 644
 645     # Uses grep to search all tracks in all contigs
 646     # for a given pattern and return a list of KISS entries.
 647
 648     my ( $cookie,   # cookie hash
 649        ) = @_;
 650
 651     # Returns a list.
 652
 653     my ( $search_track, $search_term, $contig, @tracks, $track, $file, $line, $out_file, $fh, $entry, @entries, $track_name );
 654
 655     if ( $cookie->{ 'SEARCH' } =~ /^(.+)\s+track:\s*(.+)/i )
 656     {
 657         $search_term  = $1;
 658         $search_track = $2;
 659
 660         $search_track =~ tr/ /_/;
 661     }
 662     else
 663     {
 664         $search_term = $cookie->{ 'SEARCH' };
 665     }
 666
 667     foreach $contig ( @{ $cookie->{ 'LIST_CONTIG' } } )
 668     {
 669         $cookie->{ 'CONTIG' } = $contig;
 670
 671         push @tracks, list_track_dir( $cookie->{ 'USER' }, $cookie->{ 'CLADE' }, $cookie->{ 'GENOME' }, $cookie->{ 'ASSEMBLY' }, $cookie->{ 'CONTIG' } );
 672     }
 673
 674     foreach $track ( @tracks )
 675     {
 676         if ( $search_track )
 677         {
 678             $track_name = ( split "/", $track )[ -1 ];
 679
 680             next if $track_name !~ /$search_track/i;
 681         }
 682
 683         $file = "$track/track_data.kiss";
 684
 685         if ( -f $file )
 686         {
 687             $fh = Maasha::Filesys::file_read_open( $file );
 688
 689             while ( $line = <$fh> )
 690             {
 691                 chomp $line;
 692
 693                 if ( $line =~ /$search_term/i )
 694                 {
 695                     $entry = Maasha::KISS::kiss_entry_parse( $line );
 696                     $entry = Maasha::KISS::kiss2biopiece( $entry );
 697                     push @entries, $entry;
 698                 }
 699             }
 700
 701             close $fh;
 702         }
 703     }
 704
 705     return wantarray ? @entries : \@entries;
 706 }
 707
 708
 709 sub list_user_dir
 710 {
 711     # Martin A. Hansen, December 2009.
 712
 713     # List all users directories in the ~/Data/Users
 714     # directory with full path.
 715
 716     # Returns a list.
 717
 718     my ( @dirs, @users );
 719
 720     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 721
 722     @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users" );
 723
 724     @users = grep { $_ !~ /\/\.\.?$/ } @dirs;
 725
 726     return wantarray ? @users : \@users;
 727 }
 728
 729
 730 sub list_users
 731 {
 732     # Martin A. Hansen, December 2009.
 733
 734     # List all users in ~/Data/Users
 735
 736     # Returns a list.
 737
 738     my ( @dirs, $dir, @users );
 739
 740     @dirs = list_user_dir();
 741
 742     foreach $dir ( @dirs ) {
 743         push @users, ( split "/", $dir )[ -1 ];
 744     }
 745
 746     return wantarray ? @users : \@users;
 747 }
 748
 749
 750 sub list_clade_dir
 751 {
 752     # Martin A. Hansen, December 2009.
 753
 754     # List all clades for a given user in ~/Data/Users
 755
 756     my ( $user,   # user for which to return clades
 757        ) = @_;
 758
 759     # Returns a list.
 760
 761     my ( @dirs, @clades );
 762
 763     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 764
 765     @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user" );
 766
 767     @clades = grep { $_ !~ /\/\.\.?$/ } @dirs;
 768
 769     return wantarray ? @clades : \@clades;
 770 }
 771
 772
 773 sub list_clades
 774 {
 775     # Martin A. Hansen, December 2009.
 776
 777     # List all clades for a given user in ~/Data/Users
 778
 779     my ( $user,   # user for which to return clades
 780        ) = @_;
 781
 782     # Returns a list.
 783
 784     my ( @dirs, $dir, @clades );
 785
 786     @dirs = list_clade_dir( $user );
 787
 788     foreach $dir ( @dirs ) {
 789         push @clades, ( split "/", $dir )[ -1 ];
 790     }
 791
 792     return wantarray ? @clades : \@clades;
 793 }
 794
 795
 796 sub list_genome_dir
 797 {
 798     # Martin A. Hansen, December 2009.
 799
 800     # List all genomes for a given user and clade in ~/Data/Users
 801
 802     my ( $user,    # user for which to return genomes
 803          $clade,   # clade for which to return genomes
 804        ) = @_;
 805
 806     # Returns a list.
 807
 808     my ( @dirs, @genomes );
 809
 810     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 811
 812     @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade" );
 813
 814     @genomes = grep { $_ !~ /\/\.\.?$/ } @dirs;
 815
 816     return wantarray ? @genomes : \@genomes;
 817 }
 818
 819
 820 sub list_genomes
 821 {
 822     # Martin A. Hansen, December 2009.
 823
 824     # List all genomes for a given user and clade in ~/Data/Users
 825
 826     my ( $user,    # user for which to return genomes
 827          $clade,   # clade for which to return genomes
 828        ) = @_;
 829
 830     # Returns a list.
 831
 832     my ( @dirs, $dir, @genomes );
 833
 834     @dirs = list_genome_dir( $user, $clade );
 835
 836     foreach $dir ( @dirs ) {
 837         push @genomes, ( split "/", $dir )[ -1 ];
 838     }
 839
 840     return wantarray ? @genomes : \@genomes;
 841 }
 842
 843
 844 sub list_assembly_dir
 845 {
 846     # Martin A. Hansen, December 2009.
 847
 848     # List all assemblies for a given user and clade and genome in ~/Data/Users
 849
 850     my ( $user,     # user for which to return assemblies
 851          $clade,    # clade for which to return assemblies
 852          $genome,   # genome for which to return assemblies
 853        ) = @_;
 854
 855     # Returns a list.
 856
 857     my ( @dirs, @assemblies );
 858
 859     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 860
 861     if ( $user and $clade and $genome ) {
 862         @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade/$genome" );
 863     }
 864
 865     @assemblies = grep { $_ !~ /\/\.\.?$/ } @dirs;
 866
 867     return wantarray ? @assemblies : \@assemblies;
 868 }
 869
 870
 871 sub list_assemblies
 872 {
 873     # Martin A. Hansen, December 2009.
 874
 875     # List all assemblies for a given user and clade and genome in ~/Data/Users
 876
 877     my ( $user,     # user for which to return assemblies
 878          $clade,    # clade for which to return assemblies
 879          $genome,   # genome for which to return assemblies
 880        ) = @_;
 881
 882     # Returns a list.
 883
 884     my ( @dirs, $dir, @assemblies );
 885
 886     @dirs = list_assembly_dir( $user, $clade, $genome );
 887
 888     foreach $dir ( @dirs ) {
 889         push @assemblies, ( split "/", $dir )[ -1 ];
 890     }
 891
 892     return wantarray ? @assemblies : \@assemblies;
 893 }
 894
 895
 896 sub list_contig_dir
 897 {
 898     # Martin A. Hansen, December 2009.
 899
 900     # List all assemblies for a given user->clade->genome->assembly in ~/Data/Users
 901
 902     my ( $user,       # user for which to return contigs
 903          $clade,      # clade for which to return contigs
 904          $genome,     # genome for which to return contigs
 905          $assembly,   # assembly for which to return contigs
 906        ) = @_;
 907
 908     # Returns a list.
 909
 910     my ( @dirs, @contigs );
 911
 912     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 913
 914     if ( $user and $clade and $genome and $assembly ) {
 915         @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade/$genome/$assembly" );
 916     }
 917
 918     @contigs = grep { $_ !~ /\/\.\.?$/ } @dirs;
 919
 920     return wantarray ? @contigs : \@contigs;
 921 }
 922
 923
 924 sub list_contigs
 925 {
 926     # Martin A. Hansen, December 2009.
 927
 928     # List all contigs for a given user->clade->genome->assembly in ~/Data/Users
 929
 930     my ( $user,       # user for which to return contigs
 931          $clade,      # clade for which to return contigs
 932          $genome,     # genome for which to return contigs
 933          $assembly,   # assembly for which to return contigs
 934        ) = @_;
 935
 936     # Returns a list.
 937
 938     my ( @dirs, $dir, @contigs );
 939
 940     @dirs = list_contig_dir( $user, $clade, $genome, $assembly );
 941
 942     foreach $dir ( @dirs ) {
 943         push @contigs, ( split "/", $dir )[ -1 ];
 944     }
 945
 946     return wantarray ? @contigs : \@contigs;
 947 }
 948
 949
 950 sub list_track_dir
 951 {
 952     # Martin A. Hansen, December 2009.
 953
 954     # List all tracks for a given user->clade->genome->assembly->contig in ~/Data/Users
 955
 956     my ( $user,       # user for which to return tracks
 957          $clade,      # clade for which to return tracks
 958          $genome,     # genome for which to return tracks
 959          $assembly,   # assembly for which to return tracks
 960          $contig,     # contig for which to return tracks
 961        ) = @_;
 962
 963     # Returns a list.
 964
 965     my ( @dirs, @tracks );
 966
 967     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 968
 969     if ( -d "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade/$genome/$assembly/$contig/Tracks" ) {
 970         @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade/$genome/$assembly/$contig/Tracks" );
 971     }
 972
 973     @tracks = grep { $_ !~ /\/\.\.?$/ } @dirs;
 974
 975     return wantarray ? @tracks : \@tracks;
 976 }
 977
 978
 979 sub list_tracks
 980 {
 981     # Martin A. Hansen, December 2009.
 982
 983     # List all tracks for a given user->clade->genome->assembly->contig in ~/Data/Users
 984
 985     my ( $user,       # user for which to return tracks
 986          $clade,      # clade for which to return tracks
 987          $genome,     # genome for which to return tracks
 988          $assembly,   # assembly for which to return tracks
 989          $contig,     # contig for which to return tracks
 990        ) = @_;
 991
 992     # Returns a list.
 993
 994     my ( @dirs, $dir, @tracks );
 995
 996     @dirs = list_track_dir( $user, $clade, $genome, $assembly, $contig );
 997
 998     foreach $dir ( @dirs ) {
 999         push @tracks, ( split "/", $dir )[ -1 ];
1000     }
1001
1002     return wantarray ? @tracks : \@tracks;
1003 }
1004
1005
1006 sub max_track
1007 {
1008     # Martin A. Hansen, December 2009.
1009
1010     # Traverses all contigs for a given user->clade->genome->assembly and
1011     # returns the maximum track's prefix value eg. 20 for 20_Genbank.
1012
1013     my ( $user,
1014          $clade,
1015          $genome,
1016          $assembly
1017        ) = @_;
1018
1019     # Returns an integer
1020
1021     my ( @contigs, $contig, @tracks, $max );
1022
1023     @contigs = list_contigs( $user, $clade, $genome, $assembly );
1024
1025     foreach $contig ( @contigs ) {
1026         push @tracks, list_tracks( $user, $clade, $genome, $assembly, $contig );
1027     }
1028
1029     @tracks = sort @tracks;
1030
1031     if ( scalar @tracks > 0 and $tracks[ -1 ] =~ /^(\d+)/ ) {
1032         $max = $1;
1033     } else {
1034         $max = 0;
1035     }
1036
1037     return $max;
1038 }
1039
1040
1041 sub track_hide
1042 {
1043     # Martin A. Hansen, March 2010.
1044
1045     # Check cookie information to see if a given track
1046     # should be hidden or not.
1047
1048     my ( $cookie,   # cookie hash
1049          $track,    # track name
1050        ) = @_;
1051
1052     # Returns boolean.
1053
1054     my ( $clade, $genome, $assembly );
1055
1056     $clade    = $cookie->{ 'CLADE' };
1057     $genome   = $cookie->{ 'GENOME' };
1058     $assembly = $cookie->{ 'ASSEMBLY' };
1059
1060     if ( exists $cookie->{ 'TRACK_STATUS' }->{ $clade }->{ $genome }->{ $assembly }->{ $track } and
1061                 $cookie->{ 'TRACK_STATUS' }->{ $clade }->{ $genome }->{ $assembly }->{ $track } )
1062     {
1063         return 1;
1064     }
1065
1066     return 0;
1067 }
1068
1069
1070 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
1071
1072 1;
1073
1074 __END__
1075
1076
1077 sub search_tracks_nc
1078 {
1079     # Martin A. Hansen, December 2009.
1080
1081     # Uses grep to search all tracks in all contigs
1082     # for a given pattern and return a list of KISS entries.
1083
1084     my ( $cookie,   # cookie hash
1085        ) = @_;
1086
1087     # Returns a list.
1088
1089     my ( $search_track, $search_term, $contig, @tracks, $track, $file, @features, $track_name, $nc_list );
1090
1091     if ( $cookie->{ 'SEARCH' } =~ /^(.+)\s+track:\s*(.+)/i )
1092     {
1093         $search_term  = $1;
1094         $search_track = $2;
1095
1096         $search_track =~ tr/ /_/;
1097     }
1098     else
1099     {
1100         $search_term = $cookie->{ 'SEARCH' };
1101     }
1102
1103     foreach $contig ( @{ $cookie->{ 'LIST_CONTIG' } } )
1104     {
1105         $cookie->{ 'CONTIG' } = $contig;
1106
1107         push @tracks, list_track_dir( $cookie->{ 'USER' }, $cookie->{ 'CLADE' }, $cookie->{ 'GENOME' }, $cookie->{ 'ASSEMBLY' }, $cookie->{ 'CONTIG' } );
1108     }
1109
1110     foreach $track ( @tracks )
1111     {
1112         if ( $search_track )
1113         {
1114             $track_name = ( split "/", $track )[ -1 ];
1115
1116             next if $track_name !~ /$search_track/i;
1117         }
1118
1119         $file = "$track/track_data.kiss.json";
1120
1121         if ( -f $file )
1122         {
1123             $nc_list  = Maasha::NClist::nc_list_retrieve( $file );
1124             push @features, Maasha::NClist::nc_list_search( $nc_list, $search_term, 12 );
1125         }
1126     }
1127
1128     return wantarray ? @features : \@features;
1129 }
1130
1131
1132
1133 sub track_feature
1134 {
1135     # Martin A. Hansen, November 2009.
1136
1137     # Create a track with features. If there are more than $cookie->FEAT_MAX
1138     # features the track created will be a histogram, else linear.
1139
1140     my ( $track,    # path to kiss file with track data
1141          $cookie,   # cookie hash
1142        ) = @_;
1143
1144     # Returns a list.
1145
1146     my ( $index, $count, $track_name, $start, $end, $entries, $features );
1147
1148     $start = $cookie->{ 'NAV_START' };
1149     $end   = $cookie->{ 'NAV_END' };
1150
1151     $index = Maasha::KISS::kiss_index_retrieve( "$track/track_data.kiss.index" );
1152     $count = Maasha::KISS::kiss_index_count( $index, $start, $end );
1153
1154     $track_name = ( split "/", $track )[ -1 ];
1155     $track_name =~ s/^\d+_//;
1156     $track_name =~ s/_/ /g;
1157
1158     $features = [ {
1159         type      => 'text',
1160         txt       => $track_name,
1161         font_size => $cookie->{ 'SEQ_FONT_SIZE' },
1162         color     => $cookie->{ 'SEQ_COLOR' },
1163         x1        => 0,
1164         y1        => $cookie->{ 'TRACK_OFFSET' },
1165     } ];
1166
1167     $cookie->{ 'TRACK_OFFSET' } += 10;
1168
1169     if ( $count > $cookie->{ 'FEAT_MAX' } )
1170     {
1171         $entries  = Maasha::KISS::kiss_index_get_blocks( $index, $start, $end );
1172         push @{ $features }, track_feature_histogram( $cookie, $start, $end, $entries );
1173     }
1174     else
1175     {
1176         $entries  = Maasha::KISS::kiss_index_get_entries( "$track/track_data.kiss", $index, $start, $end );
1177         push @{ $features }, track_feature_linear( $cookie, $start, $end, $entries );
1178     }
1179
1180     return wantarray ? @{ $features } : $features;
1181 }