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