view release on metacpan or  search on metacpan

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

                   : 'application/octet-stream'
		      if $config->{format} eq 'todisk';
  return 'text/plain';
}

sub config_defaults {
  my $self = shift;
  my $browser_config = $self->browser_config;

  # try to get the codon table to use
  # first priority is the geneticcode or codontabe setting in the plugin config section
  my $default_code = $browser_config->plugin_setting('geneticcode') || $browser_config->plugin_setting('codontable');

  # second priority is the setting in any "translation" track.
  unless (defined $default_code) { # search config file for a translation track
    for my $label ($browser_config->labels) {
      next unless $browser_config->setting($label => 'glyph') eq 'translation';
      $default_code ||= $browser_config->setting($label => 'geneticcode')
	|| $browser_config->setting($label => 'codontable');
      last if $default_code;
    }
  }

  # last try, set to 1
  $default_code ||= 1;

  return { format           => 'html',
	   fileformat       => 'fasta',
           geneticcode      => $default_code,
       };
}

sub reconfigure {
  my $self = shift;
  my $current_config = $self->configuration;

  foreach my $param ( $self->config_param() ) {
      $current_config->{$param} = $self->config_param($param);
  }
}

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 todisk)],
				     -default  => $current_config->{'format'},
				     -labels   => {html => 'html/xml',
						   'todisk' => 'Save to Disk',
						  },
				     -override => 1,
				    )
			)
		     )
		  );

  push @choices, TR({-class => 'searchtitle'},
		    th({-align=>'RIGHT',-width=>'25%'},"Sequence File Format",
		       td(popup_menu('-name'   => $self->config_name('fileformat'),
				     '-values' => \@ORDER,
				     '-labels' => \%LABELS,
				     '-default'=> $current_config->{'fileformat'},
				    )
			 )
		      )
		   );

  push @choices, TR({-class => 'searchtitle'},
		    th({-align=>'RIGHT',-width=>'25%'},"Genetic Code",
		       td(popup_menu('-name'   => $self->config_name('geneticcode'),
				     '-values' => [
						   grep {
						     $Bio::Tools::CodonTable::NAMES[$_-1]
						   } 1..@Bio::Tools::CodonTable::NAMES
						  ],
				     '-labels' => {
						   map {
						     ( $_ => $Bio::Tools::CodonTable::NAMES[$_-1] )
						   } grep {
						     $Bio::Tools::CodonTable::NAMES[$_-1]
						   } 1..@Bio::Tools::CodonTable::NAMES
						  },
				     '-default'=> $current_config->{'geneticcode'},
				    )
			 )
		      )
		   );

  my $html= table(@choices);
  $html;
}

sub gff_dump {
  my $self          = shift;
  my $segment       = shift;
  my $page_settings = $self->page_settings;
  my $conf          = $self->browser_config;
  my $date = localtime;

  my $mime_type = $self->mime_type;
  my $html      = $mime_type =~ /html/;
  print start_html($segment) if $html;
  
  print h1($segment),start_pre() if $html;
  print "##gff-version 2\n";
  print "##date $date\n";
  print "##sequence-region ",join(' ',$segment->ref,$segment->start,$segment->end),"\n";
  print "##source gbrowse SequenceDumper\n";
  print "##See http://www.sanger.ac.uk/Software/formats/GFF/\n";
  print "##NOTE: Selected features dumped.\n";
  my @feature_types = $self->selected_features;
  $segment->absolute(0);
  my $iterator = $segment->get_seq_stream(-types => \@feature_types) or return;
  while (my $f = $iterator->next_seq) {
    print $f->gff_string,"\n";
    for my $s ($f->sub_SeqFeature) {
      print $s->gff_string,"\n";
    }
  }
  print end_pre() if $html;
  print end_html() if $html;
}

sub _collect_cds {
    my $self = shift;
    my $feature = shift;
    if ($feature->type =~ /^CDS/i) {return $feature};
    my @sub = $feature->get_SeqFeatures;
    return unless @sub;
    return map {$self->_collect_cds($_)} @sub;