view release on metacpan or  search on metacpan

conf/plugins/FastaDumper.pm  view on Meta::CPAN

  foreach my $param ( $self->config_param() ) {
    warn "param = $param\n" if DEBUG;
    next if $param =~/\.(f|b)gcolor$/;
    my $value = $self->config_param($param) or next;
    $current_config->{$param} = $value;
    warn "current_config($param) = $current_config->{$param}\n" if DEBUG;
  }
  # handle colors specially
  for my $type (keys %$current_config) {
    next unless $current_config->{$type} =~ /^\d+$/;
    next unless $MARKUPS[$current_config->{$type}] =~ /^(F|B)GCOLOR/;
    my $color_key = lc("$1gcolor");
    $current_config->{"$type.$color_key"} = $self->config_param("$type.$color_key");
    warn "current_config($type.$color_key) = ",$current_config->{"$type.$color_key"},"\n" if DEBUG;
  }
}

sub configure_form {
    my $self = shift;
    my $current_config = $self->configuration;
    my @choices = TR({-class => 'searchtitle'},
		     th({-align=>'RIGHT',-width=>'25%'},"Output",
			td(radio_group(-name     => $self->config_name('format'),
				       -values   => [qw(text html)],
				       -default  => $current_config->{'format'},
				       -override => 1))
		       )
		    );
  push @choices,TR({-class=>'searchtitle'},
		   th({-align=>'RIGHT',-width=>'25%'},"Orientation",
		      td(checkbox(-name    => $self->config_name('flip'),
				  -label   => 'Flip',
				  -checked => $self->page_settings->{flip},
				  -override => 1))));

    my $browser = $self->browser_config();
    # this to be fixed as more general
    my @labels;
    foreach ( $browser->labels() ) {
	push @labels, $_ unless ! defined $browser->setting($_,'feature');
    }

    autoEscape(0);
    my %selected = map {$_=>1} ($self->selected_tracks);

    foreach my $featuretype ( @labels ) {
        next if ! $selected{$featuretype};
	my $realtext = $browser->setting($featuretype,'key') || $featuretype;
	push @choices, TR({-class => 'searchtitle'}, 
			  th({-align=>'RIGHT',-width=>'25%'}, $realtext,
			     td(join (' ',
				      radio_group(-name     => $self->config_name($featuretype),
						  -values   => [ (sort keys %LABELS)[0..4] ],
						  -labels   => \%LABELS,
						  -default  => $current_config->{$featuretype} || 0),
				      radio_group(-name     => $self->config_name($featuretype),
						  -values   => 5,
						  -labels   => \%LABELS,
						  -default  => $current_config->{$featuretype} || 0),
				      popup_menu(-name      => $self->config_name("$featuretype.fgcolor"),
						 -values    => \@COLORS,
						 -default    => $current_config->{"$featuretype.fgcolor"}),
				      radio_group(-name     => $self->config_name($featuretype),
						  -values   => 6,
						  -labels   => \%LABELS,
						  -default  => $current_config->{$featuretype} || 0),
				      popup_menu(-name      => $self->config_name("$featuretype.bgcolor"),
						 -values    => \@COLORS,
						 -default    => $current_config->{"$featuretype.bgcolor"}
						),
				     ))));
    }
    autoEscape(1);
    my $html= table({-width=>'100%'},@choices);
    $html;
}


sub make_markup {
  my $self = shift;
  my ($segment,$types,$markup,$flip) = @_;

  my @regions_to_markup;

  warn("segment length is ".$segment->length()."\n") if DEBUG;
  my $iterator = $segment->get_seq_stream(-types=>$types,
					  -automerge=>1) or return;
  my $segment_start = $segment->start;
  my $segment_end   = $segment->end;
  my $segment_length = $segment->length;

  while (my $markupregion = $iterator->next_seq) {

    warn "got feature $markupregion\n" if DEBUG;

    # handle both sub seqfeatures and split locations...
    # somebody rescue me from this insanity!
    my @parts = eval { $markupregion->sub_SeqFeature } ;
    @parts = eval { my $id   = $markupregion->location->seq_id;
		    my @subs = $markupregion->location->sub_Location;
		    grep {$id eq $_->seq_id} @subs } unless @parts;
    @parts = ($markupregion) unless @parts;

    for my $p (@parts) {
      my $start = $p->start - $segment_start;
      my $end   = $start + $p->length;

      $start++ if $p->strand < 0;
      ($start,$end) = map {$segment_length-$_} ($end,$start) if $flip;

      warn("$p ". $p->location->to_FTstring() . " type is ".$p->primary_tag) if DEBUG;
      $start = 0                   if $start < 0;  # this can happen
      $end   = $segment->length    if $end > $segment->length;
      warn "annotating $p $start..$end" if DEBUG;

      my $style_symbol;
      foreach ($p->type,$p->method,$markupregion->type,$markupregion->method) {
	$style_symbol ||= $markup->valid_symbol($_) ? $_ : undef;
      }
      warn "style symbol for $p is $style_symbol, and style is ",$markup->style($style_symbol),"\n" if DEBUG;
      next unless $style_symbol;

      warn "[$style_symbol,$start,$end]\n" if DEBUG;
      push @regions_to_markup,[$style_symbol,$start,$end];
    }
  }
  @regions_to_markup;