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