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