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