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