view release on metacpan or  search on metacpan

lib/Bio/Graphics/Glyph/topoview.pm  view on Meta::CPAN

        $gd->rectangle($x,$y,$x+10,$y+10,$edgecolor);
        $gd->filledRectangle($x,$y,$x+10,$y+10,$color);
        $x += 14;
        $gd->string($font,$x,$y,$subset,$black);
        $x += $longest_string + 8;
    }
}

#--------------------------
sub getData {
    my $self = shift;
    my($ft,$datadir,$chromosome,$start,$stop,$scrstart,$scrstop,$flipped,$gd) = @_;
    my $global_max_signal = $self->option('max_score') || 0;
    my %Signals = ();
    $self->openDataFiles($datadir);

    my $subset_text = $self->option('subset order');
    if ($subset_text) {
	my @words = shellwords($subset_text);

	# subset + color
	if (!(@words %2) && $words[1] =~ /^[0-9A-F]{6}$/ && $words[2] !~ /^[.0-9]+$/) {
	    while (@words) {
		push @{$ft->{subsetsorder}}, [splice(@words,0,2)];
	    }
	}
	# subset + color + alpha
	elsif (!(@words %3) && $words[1] =~ /^[0-9A-F]{6}$/) {
            while (@words) {
                push @{$ft->{subsetsorder}}, [splice(@words,0,3)];
            }
        }
	# no color specified? Random color for you. Good luck!
	else {
	    for my $word (@words) {
		push @{$ft->{subsetsorder}}, [$word,$self->random_color()];
	    }
	}

    }

    my @subsets = (exists $ft->{'subsetsorder'}) ? @{$ft->{'subsetsorder'}} : sort split(/\t+/,$Indices{'subsets'});

    my $user_max = $self->option('max_score');

    # This bit of code reads in user-specified bgcolor, if provided
    if ( ref $subsets[0] eq 'ARRAY' ) {
	for (@subsets) {
	    next unless ref $_ eq 'ARRAY';
	    my ($subset,$color,$alpha)  = @$_;
	    $alpha ||= $self->option('fill opacity') || 1.0;

	    if ($alpha && $alpha > 1) {
		die "Alpha must be between zero and 1";
	    }
	    
	    # make it hex if it looks like hex
	    if ((length $color == 6) && $color =~ /^[0-9A-F]+$/) {
		$color = '#'.$color;
	    } 
	    my $bgcolor = $self->factory->transparent_color($alpha,$color);
	    my $fgcolor = $self->translate_color($color);
	    $self->{bgcolor}->{$subset} = $bgcolor;
	    
	    # We will re-use this array later
	    $_ = $subset;
	}
    }

    shift(@subsets) if $subsets[0] eq 'MAX';
    warn("subsets: @subsets\n") if DEBUG;

    my %SubsetsNames = (exists $ft->{'subsetsnames'}) ? %{$ft->{'subsetsnames'}} : map { $_, $_ } @subsets;
    $SubsetsNames{MAX}= 'MAX'; 
    my $screenstep = ($scrstop-$scrstart+1) * 1.0 / ($stop-$start+1);
    my $donecoords = 0;
    my $local_max_signal = 0;

    foreach my $subset ( @subsets ) {
	my $nstrings = 0;
	# scan seq ranges offsets to see where to start reading
	my $key = $subset.':'.$chromosome;
	my $poskey = $key.':offsets';
	my $ranges_pos = (exists $Indices{$poskey}) ? int($Indices{$poskey}) : -1;
	if( $ranges_pos == -1 ) { next; } # no such signal..
	warn("  positioning for $poskey starts at $ranges_pos\n") if DEBUG;
	if( $start>=1000000 ) {  
	    my $bigstep = int($start/1000000.0);
	    if( exists $Indices{$key.':offsets:'.$bigstep} ) {
		my $jumpval = $Indices{$key.':offsets:'.$bigstep}; 
		warn("  jump in offset search to $jumpval\n") if DEBUG;
		$ranges_pos = int($jumpval); }
	}
	seek(DATF,$ranges_pos,0);
	my($offset,$offset1)= (0,0);
	my $lastseqloc = -999999999;
	my $useoffset = 0;
	while( (my $strs =<DATF>) ) {
	    $nstrings++ if DEBUG;
	    if( DEBUG ) {
		chop($strs); warn("  	positioning read for coord $start ($strs)\n"); }
	    last unless $strs =~m/^(-?\d+)[ \t]+(\d+)/;
	    my($seqloc,$fileoffset)= ($1,$2);
	    if( DEBUG ) {
		chop($strs); warn("  positioning read for $poskey => $seqloc, $fileoffset ($strs)\n"); }
	    $offset1 = $offset;
	    $offset = $fileoffset;
	    $lastseqloc = $seqloc;
	    if( $seqloc > $start ) { $useoffset = int($offset1); last; } 
	}
	warn("  will use offset $useoffset\n") if DEBUG;
	warn("  	(scanned $nstrings offset strings)\n") if DEBUG;
	if( $useoffset ==0 ) { # data offset cannot be 0 - means didn't find where to read required data..
	    next;
	    my @emptyvals = ();
	    for( my $ii = $scrstart; $ii++ <= $scrstop; ) { push(@emptyvals,0); }
	    $Signals{$subset}= \@emptyvals;
	}
	$nstrings = 0;
	# read signal profile 
	seek(DATF,$useoffset,0);