added zoom and move to KISS

git-svn-id: http://biopieces.googlecode.com/svn/trunk@709 74ccb610-7750-0410-82ae-013aeee3265d

diff --git a/code_perl/Maasha/Calc.pm b/code_perl/Maasha/Calc.pm
index b8941688888b08e118a80acd465906581dd33d79..131643437475778dc19ffbd04842350159c53203 100644 (file)
--- a/code_perl/Maasha/Calc.pm
+++ b/code_perl/Maasha/Calc.pm
@@ -59,6 +59,19 @@ sub is_a_number
 }
 
 
+sub commify
+{
+    # Martin A. Hansen, October 2009.
+
+    # Insert comma in long numbers.
+
+    my ( $num,   # number reference to commify
+       ) = @_;
+
+    ${ $num } =~ s/(^[-+]?\d+?(?=(?>(?:\d{3})+)(?!\d))|\G\d{3}(?=\d))/$1,/g;
+}
+
+
 sub dist_point2line
 {
     # Martin A. Hansen, June 2004.

diff --git a/code_perl/Maasha/KISS/Draw.pm b/code_perl/Maasha/KISS/Draw.pm
index a35f73f469103bd62423364a8cbaa40cec73c9ef..df21300527b1451ee333d901ee5988625b0e3176 100644 (file)
--- a/code_perl/Maasha/KISS/Draw.pm
+++ b/code_perl/Maasha/KISS/Draw.pm
@@ -100,6 +100,12 @@ sub svg_frame
 }
 
 
+sub svg_track_dna
+{
+
+}
+
+
 sub svg_track_feature
 {
     # Martin A. Hansen, October 2009.
@@ -142,6 +148,42 @@ sub svg_track_feature
 }
 
 
+sub svg_track_histogram
+{
+    # Given a list of features add these to
+    # a SVG object.
+
+    my ( $svg,        # SVG object
+         $features,   # List of features
+         $track_id,   # Unique track id
+         $color,      # Color of features 
+       ) = @_;
+
+    # Returns nothing.
+
+    my ( $track, $i );
+
+    $track = $svg->group(
+        id => $track_id,
+        style => {
+            'stroke-width' => 5,
+            stroke         => $color,
+        }
+    );
+
+    for ( $i = 0; $i < @{ $features }; $i++ )
+    {
+        $track->line(
+            id => "HIST_$i",
+            x1 => $features->[ $i ]->{ 'x1' },
+            y1 => $features->[ $i ]->{ 'y1' },
+            x2 => $features->[ $i ]->{ 'x2' },
+            y2 => $features->[ $i ]->{ 'y2' },
+        );
+    }
+}
+
+
 sub svg_print
 {
     # Martin A. Hansen, October 2009.
@@ -160,6 +202,22 @@ sub svg_print
 }
 
 
+sub hdump
+{
+    my ( $foo ) = @_;
+
+    my ( @html );
+
+    @html = "Content-Type: text/html; charset=ISO-8859-1\n\n";
+
+    push @html, "<pre>\n";
+    push @html, Dumper( $foo );
+    push @html, "</pre>\n";
+
+    return wantarray ? @html : \@html;
+}
+
+
 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 
 1;

diff --git a/code_perl/Maasha/KISS/Track.pm b/code_perl/Maasha/KISS/Track.pm
index f6639ea3a93e8e58c1d80a82cfc072256b966d87..5b147d5bc207565462c4daa8cbac430de8fde97d 100644 (file)
--- a/code_perl/Maasha/KISS/Track.pm
+++ b/code_perl/Maasha/KISS/Track.pm
@@ -84,7 +84,7 @@ sub track_feature
             $y = $y_offset + ( 5 * $y_step );
 
             push @features, {
-                id     => $entry->{ 'Q_ID' },
+#                id     => $entry->{ 'Q_ID' },
                 x      => $x,
                 y      => $y,
                 height => 5,
@@ -99,6 +99,96 @@ sub track_feature
 }
 
 
+sub track_histogram
+{
+    my ( $width,     # draw window width
+         $y_offset,  # y axis draw offset
+         $min,       # minimum base position
+         $max,       # maximum base position
+         $entries,   # list of sorted KISS entries 
+       ) = @_;
+
+    # Returns a list.
+
+    my ( $hist_height, $bucket_width, $factor_heigth, $factor_width, $entry, $max_height, $bucket_beg, $bucket_end, $i, @buckets, $bucket, @hist, $x, $h );
+
+    return if $max == $min;
+
+    $hist_height  = 100;   # pixels
+    $bucket_width = 5;     # pixels
+
+    $factor_width = ( $width / $bucket_width ) / ( $max - $min );
+
+    $max_height = 0;
+
+    foreach $entry ( @{ $entries } )
+    {
+        $bucket_beg = int( $entry->{ 'S_BEG' } * $factor_width );
+        $bucket_end = int( $entry->{ 'S_END' } * $factor_width );
+
+        # print "$bucket_beg   $bucket_end\n";
+    
+        for ( $i = $bucket_beg; $i <= $bucket_end; $i++ )
+        {
+            $buckets[ $i ]++;
+
+            $max_height = Maasha::Calc::max( $max_height, $buckets[ $i ] );
+        }
+    }
+
+    # print Maasha::KISS::Draw::hdump( \@buckets );
+    #print Dumper( $max_height );
+
+    if ( $max_height > 0 )
+    {
+        $factor_heigth = $hist_height / $max_height;
+
+        $x = 0;
+
+        for ( $i = int( $entries->[ 0 ]->{ 'S_BEG' } * $factor_width ); $i < @buckets; $i++ )
+        {
+            if ( defined $buckets[ $i ] )
+            {
+                $h = sprintf( "%.0f", $buckets[ $i ] * $factor_heigth );
+
+                if ( $h >= 1 )
+                {
+                    push @hist, {
+                        x1      => $x,
+                        y1      => $y_offset + $hist_height,
+                        x2      => $x,
+                        y2      => $y_offset + $hist_height - $h,
+                    };
+                }
+            }
+
+            $x += $bucket_width;
+        }
+    }
+
+    return wantarray ? @hist : \@hist;
+}
+
+
+sub bucket_round
+{
+    my ( $num,
+         $bucket_size,
+       ) = @_;
+    
+    my ( $div, $int );
+
+    $div = $num / $bucket_size;
+    $int = int $div;
+
+    if ( $div - $int >= 0.5 ) {
+        return $bucket_size * ( $int + 1 );
+    } else {
+        return $bucket_size * $int;
+    }
+}
+
+
 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 
 1;

diff --git a/code_perl/Maasha/SQL.pm b/code_perl/Maasha/SQL.pm
index be6099921a395c102c38228af3dee1a824ceab6a..70985249a4048d46cab5508a6f4f288f0e26c22e 100644 (file)
--- a/code_perl/Maasha/SQL.pm
+++ b/code_perl/Maasha/SQL.pm
@@ -263,7 +263,7 @@ sub query_hashref_list
 
     # Returns datastructure.
 
-    my $table = $dbh->selectall_arrayref( $sql, { Slice => {} } );
+    my $table = $dbh->selectall_arrayref( $sql, { Slice => {} } ); # This call is slow! :o(
 
     return wantarray ? @{ $table } : $table;
 }

diff --git a/www/cgi-bin/index.cgi b/www/cgi-bin/index.cgi
index b1827d4f56a3b5ee1c0c74a38f0c172543fd8940..525dfd1cfb8c29908674e7e80e7e0e16c744210a 100755 (executable)
--- a/www/cgi-bin/index.cgi
+++ b/www/cgi-bin/index.cgi
@@ -27,6 +27,7 @@ use lib "/Users/maasha/biopieces/code_perl/";
 
 use CGI;
 use Data::Dumper;
+use Time::HiRes;
 use Maasha::Common;
 use Maasha::Filesys;
 use Maasha::XHTML;
@@ -62,7 +63,7 @@ push @html, Maasha::XHTML::h1( txt => "KISS Genome Browser", class => "center" )
 push @html, Maasha::XHTML::form_beg( action => $script, method => "get", enctype => "multipart/form-data" );
 
 push @html, sec_navigate( $cgi );
-push @html, sec_browse( $cgi, $dbh );
+push @html, sec_browse( $dbh, $cgi->param( 'nav_start' ), $cgi->param( 'nav_end' ) );
 
 push @html, Maasha::XHTML::form_end;
 push @html, Maasha::XHTML::body_end;
@@ -88,6 +89,9 @@ sub sec_navigate
     $list_assembly = nav_list_assembly();
     $list_contig   = nav_list_contig();
 
+    nav_zoom( $cgi );
+    nav_move( $cgi, 2_800_000 ); # FIXME
+
     $def_clade     = nav_def_clade( $cgi );
     $def_genome    = nav_def_genome( $cgi );
     $def_assembly  = nav_def_assembly( $cgi );
@@ -95,6 +99,9 @@ sub sec_navigate
     $def_start     = nav_def_start( $cgi );
     $def_end       = nav_def_end( $cgi );
 
+    Maasha::Calc::commify( \$def_start );
+    Maasha::Calc::commify( \$def_end );
+
     push @html, Maasha::XHTML::table_beg( summary => "Navigation table" );
     push @html, Maasha::XHTML::table_row_simple( tr => [ qw( Clade Genome Assembly Contig Start End ) ], align => 'center' );
     push @html, Maasha::XHTML::table_row_simple( tr => [
@@ -108,29 +115,73 @@ sub sec_navigate
     ] );
     push @html, Maasha::XHTML::table_end;
 
+    push @html, Maasha::XHTML::table_beg( summary => "Zoom table" );
+    push @html, Maasha::XHTML::table_row_simple( tr => [
+        Maasha::XHTML::p( txt => 'Move:' ),
+        Maasha::XHTML::submit( name => "move_left3",  value => "<<<", title => "move 95% to the left" ),
+        Maasha::XHTML::submit( name => "move_left2",  value => "<<",  title => "move 47.5% to the left" ),
+        Maasha::XHTML::submit( name => "move_left1",  value => "<",   title => "move 10% to the left" ),
+        Maasha::XHTML::submit( name => "move_right1", value => ">",   title => "move 10% to the rigth" ),
+        Maasha::XHTML::submit( name => "move_right2", value => ">>",  title => "move 47.5% to the rigth" ),
+        Maasha::XHTML::submit( name => "move_right3", value => ">>>", title => "move 95% to the right" ),
+        Maasha::XHTML::p( txt => 'Zoom in:' ),
+        Maasha::XHTML::submit( name => "zoom_in1", value => "1.5x" ),
+        Maasha::XHTML::submit( name => "zoom_in2", value => "3x" ),
+        Maasha::XHTML::submit( name => "zoom_in3", value => "10x" ),
+        Maasha::XHTML::p( txt => 'Zoom out:' ),
+        Maasha::XHTML::submit( name => "zoom_out1", value => "1.5x" ),
+        Maasha::XHTML::submit( name => "zoom_out2", value => "3x" ),
+        Maasha::XHTML::submit( name => "zoom_out3", value => "10x" ),
+    ] );
+    push @html, Maasha::XHTML::table_end;
+
     return wantarray ? @html : \@html;
 }
 
 
 sub sec_browse
 {
-    my ( $cgi,   # CGI object
-         $dbh,   # Database handle
+    my ( $dbh,     # Database handle
+         $start,   # Browse start position
+         $end,     # Browse end position
        ) = @_;
 
     # Returns a list.
 
-    my ( $table, $def_start, $def_end, $entries, $features, $svg, $file, $fh, @html );
+    my ( $t0, $t1, $table, $entries, $features, $svg, $file, $fh, @html );
+
+    $table = 'Solexa';
 
-    $table     = 'Solexa';
-    $def_start = nav_def_start( $cgi );
-    $def_end   = nav_def_end( $cgi );
+    $t0 = Time::HiRes::gettimeofday();
+    $entries = Maasha::KISS::IO::kiss_sql_get( $dbh, $table, $start, $end );
+    $t1 = Time::HiRes::gettimeofday();
 
-    $entries = Maasha::KISS::IO::kiss_sql_get( $dbh, $table, $def_start, $def_end );
+    push @html, Maasha::XHTML::p( txt => "Feature count: " . scalar @$entries );
 
+    push @html, Maasha::XHTML::p( txt => "Time SQL: " . ( $t1 - $t0 ) );
+
+    $t0 = Time::HiRes::gettimeofday();
     Maasha::KISS::Track::entries_sort( $entries );
+    $t1 = Time::HiRes::gettimeofday();
+
+    push @html, Maasha::XHTML::p( txt => "Time sort: " . ( $t1 - $t0 ) );
 
-    $features = Maasha::KISS::Track::track_feature( 1200, 50, $def_start, $def_end, $entries );
+    $t0 = Time::HiRes::gettimeofday();
+
+    my $MAX = 4000;  # FIXME should depend on hieght of track as well
+
+    if ( @$entries > $MAX ) {
+        $features = Maasha::KISS::Track::track_histogram( 1200, 50, $start, $end, $entries );
+    } else {
+        $features = Maasha::KISS::Track::track_feature( 1200, 50, $start, $end, $entries );
+    }
+
+    $t1 = Time::HiRes::gettimeofday();
+
+    # push @html, Maasha::KISS::Draw::hdump( $entries );
+    # push @html, Maasha::KISS::Draw::hdump( $features );
+
+    push @html, Maasha::XHTML::p( txt => "Time Track: " . ( $t1 - $t0 ) );
 
     $file = "fisk.svg";
 
@@ -138,9 +189,19 @@ sub sec_browse
 
     $svg = Maasha::KISS::Draw::svg_init( 800, 1200 );
 
+    $t0 = Time::HiRes::gettimeofday();
     Maasha::KISS::Draw::svg_frame( 800, 1200, $svg );
-    Maasha::KISS::Draw::svg_track_feature( 800, 1200, $svg, $features, 'track id', 'green' );
+
+    if ( @$entries > $MAX ) {
+        Maasha::KISS::Draw::svg_track_histogram( $svg, $features, 'track id', 'green' ) if $features;
+    } else {
+        Maasha::KISS::Draw::svg_track_feature( 800, 1200, $svg, $features, 'track id2', 'green' ) if $features;
+    }
+
     Maasha::KISS::Draw::svg_print( $svg, $fh );
+    $t1 = Time::HiRes::gettimeofday();
+
+    push @html, Maasha::XHTML::p( txt => "Time Draw: " . ( $t1 - $t0 ) );
 
     close $fh;
 
@@ -195,8 +256,104 @@ sub nav_list_contig
 }
 
 
+sub nav_zoom
+{
+    my ( $cgi,   # CGI object
+       ) = @_;
+
+    my ( $start, $end, $dist, $new_dist, $dist_diff, $new_start, $new_end );
+
+    if ( defined $cgi->param( 'nav_start' ) and $cgi->param( 'nav_end' ) )
+    {
+        $start = $cgi->param( 'nav_start' );
+        $end   = $cgi->param( 'nav_end' );
+
+        $start =~ tr/,//d;
+        $end   =~ tr/,//d;
+
+        $dist = $end - $start;
+
+        if ( defined $cgi->param( 'zoom_in1' ) ) {
+            $new_dist = $dist / 1.5;
+        } elsif ( defined $cgi->param( 'zoom_in2' ) ) {
+            $new_dist = $dist / 3;
+        } elsif ( defined $cgi->param( 'zoom_in3' ) ) {
+            $new_dist = $dist / 10;
+        } elsif ( defined $cgi->param( 'zoom_out1' ) ) {
+            $new_dist = $dist * 1.5;
+        } elsif ( defined $cgi->param( 'zoom_out2' ) ) {
+            $new_dist = $dist * 3;
+        } elsif ( defined $cgi->param( 'zoom_out3' ) ) {
+            $new_dist = $dist * 10;
+        }
+
+        if ( $new_dist )
+        {
+            $dist_diff = $dist - $new_dist;
+            $new_start = int( $start + ( $dist_diff / 2 ) );
+            $new_end   = int( $end   - ( $dist_diff / 2 ) );
+
+            $cgi->param( 'nav_start', $new_start );
+            $cgi->param( 'nav_end',  $new_end );
+        }
+    }
+}
+
+
+sub nav_move
+{
+    my ( $cgi,   # CGI object
+         $max,   # Max end position
+       ) = @_;
+
+    my ( $start, $end, $dist, $shift, $new_start, $new_end );
+
+    if ( defined $cgi->param( 'nav_start' ) and $cgi->param( 'nav_end' ) )
+    {
+        $start = $cgi->param( 'nav_start' );
+        $end   = $cgi->param( 'nav_end' );
+
+        $start =~ tr/,//d;
+        $end   =~ tr/,//d;
+
+        $dist = $end - $start;
+
+        if ( defined $cgi->param( 'move_left1' ) ) {
+            $shift = -1 * $dist * 0.10;
+        } elsif ( defined $cgi->param( 'move_left2' ) ) {
+            $shift = -1 * $dist * 0.475;
+        } elsif ( defined $cgi->param( 'move_left3' ) ) {
+            $shift = -1 * $dist * 0.95;
+        } elsif ( defined $cgi->param( 'move_right1' ) ) {
+            $shift = $dist * 0.10;
+        } elsif ( defined $cgi->param( 'move_right2' ) ) {
+            $shift = $dist * 0.475;
+        } elsif ( defined $cgi->param( 'move_right3' ) ) {
+            $shift = $dist * 0.95;
+        }
+
+        if ( $shift )
+        {
+            $new_start = int( $start + $shift );
+            $new_end   = int( $end   + $shift );
+
+            print "HERRRR: shift: $shift    start: $new_start    end: $new_end\n";
+
+            if ( $new_start > 0 and $new_end < $max )
+            {
+                $cgi->param( 'nav_start', $new_start );
+                $cgi->param( 'nav_end',  $new_end );
+            }
+        }
+    }
+}
+
+
 sub nav_def_clade
 {
+    my ( $cgi,   # CGI object
+       ) = @_;
+
     my ( $def_clade );
 
     if ( defined $cgi->param( 'nav_clade' ) )
@@ -214,6 +371,9 @@ sub nav_def_clade
 
 sub nav_def_genome
 {
+    my ( $cgi,   # CGI object
+       ) = @_;
+
     my ( $def_genome );
 
     if ( defined $cgi->param( 'nav_genome' ) )
@@ -231,6 +391,9 @@ sub nav_def_genome
 
 sub nav_def_assembly
 {
+    my ( $cgi,   # CGI object
+       ) = @_;
+
     my ( $def_assembly );
 
     if ( defined $cgi->param( 'nav_assembly' ) )
@@ -248,6 +411,9 @@ sub nav_def_assembly
 
 sub nav_def_contig
 {
+    my ( $cgi,   # CGI object
+       ) = @_;
+
     my ( $def_contig );
 
     if ( defined $cgi->param( 'nav_contig' ) )
@@ -265,47 +431,62 @@ sub nav_def_contig
 
 sub nav_def_start
 {
+    my ( $cgi,   # CGI object
+       ) = @_;
+
     my ( $def_start );
 
-    if ( defined $cgi->param( 'nav_start' ) )
-    {
+    if ( defined $cgi->param( 'nav_start' ) ) {
         $def_start = $cgi->param( 'nav_start' );
+    } else {
+        $def_start = 1;
     }
-    else
-    {
+
+    $def_start =~ tr/,//d;
+
+    if ( $def_start <= 0 ) {
         $def_start = 1;
     }
 
+    $cgi->param( 'nav_start', $def_start );
+
     return $def_start;
 }
 
 
 sub nav_def_end
 {
+    my ( $cgi,   # CGI object
+       ) = @_;
+
     my ( $def_end );
     
-    if ( defined $cgi->param( 'nav_end' ) )
-    {
+    if ( defined $cgi->param( 'nav_end' ) ) {
         $def_end = $cgi->param( 'nav_end' );
+    } else {
+        $def_end = 2809422;
+        $def_end = 2000;
     }
-    else
-    {
+
+    $def_end =~ tr/,//d;
+
+    if ( $def_end > 2809422 ) {
         $def_end = 2809422;
-        $def_end = 1000;
     }
 
+    $cgi->param( 'nav_end', $def_end );
+
     return $def_end;
 }
 
 
 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 
+
 END
 {
     Maasha::SQL::disconnect( $dbh ) if $dbh;
 }
 
-__END__
-
-
 
+__END__