[Bio] / FigWebServices / protein.cgi Repository:
ViewVC logotype

View of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (download) (annotate)
Sat Jan 31 17:06:07 2004 UTC (16 years, 2 months ago) by overbeek
Branch: MAIN
Changes since 1.8: +1 -1 lines
fix formatting annotations

use FIG;
my $fig = new FIG;

use HTML;
use strict;
use GenoGraphics;
use CGI;
my $cgi = new CGI;

if (0)
{
    print $cgi->header;
    my @params = $cgi->param;
    print "<pre>\n";
    foreach $_ (@params)
    {
	print "$_\t:",join(",",$cgi->param($_)),":\n";
    }
    exit;
}

my $html = [];

my $prot = $cgi->param('prot');
if (! $prot)
{
    push(@$html,"<h1>Sorry, you need to specify a protein</h1>\n");
    &HTML::show_page($cgi,$html);
    exit;
}
my $request = $cgi->param("request");
$request = defined($request) ? $request : "";

if    ($request eq "use_protein_tool")
{
    &use_protein_tool($fig,$cgi,$prot);
}
elsif ($request eq "view_annotations")
{
    &view_annotations($fig,$cgi,$html,$prot);
}
elsif ($request eq "aa_sequence")
{
    &aa_sequence($fig,$cgi,$html,$prot);
}
elsif ($request eq "dna_sequence")
{
    &dna_sequence($fig,$cgi,$html,$prot);
}
elsif ($request eq "fast_assign")
{
    &make_assignment($fig,$cgi,$html,$prot);
}
elsif ($request eq "show_coupling_evidence")
{
    &show_coupling_evidence($fig,$cgi,$html,$prot);
}
elsif ($request eq "ec_to_maps")
{
    &show_ec_to_maps($fig,$cgi,$html);
}
elsif ($request eq "link_to_map")
{
    &link_to_map($fig,$cgi,$html);
}
elsif ($request eq "fusions")
{
    &show_fusions($fig,$cgi,$html,$prot);
}
else
{
    &show_initial($fig,$cgi,$html,$prot);
}

&HTML::show_page($cgi,$html);

sub use_protein_tool {
    my($fig,$cgi,$prot) = @_;
    my($url,$method,@args,$line,$name,$val);

    my $seq = $fig->get_translation($prot);
    if (! $seq)
    {
	push(@$html,$cgi->h1("Sorry, $prot does not have a translation"));
	return;
    }
    my $protQ = quotemeta $prot;

    my $tool = $cgi->param('tool');
    $/ = "\n//\n";
    my @tools = grep { $_ =~ /^$tool\n/ } `cat $FIG_Config::global/LinksToTools`;
    if (@tools == 1)
    {
	chomp $tools[0];
	(undef,undef,$url,$method,@args) = split(/\n/,$tools[0]);
	my $args = [];
	foreach $line (@args)
	{
	    ($name,$val) = split(/\t/,$line);
	    $val =~ s/FIGID/$prot/;
	    $val =~ s/FIGSEQ/$seq/;
	    $val =~ s/\\n/\n/g;
	    push(@$args,[$name,$val]);
	}
	push(@$html,&HTML::get_html($url,$method,$args));
    }
}

sub make_assignment {
    my($fig,$cgi,$html,$prot) = @_;
    my($userR);

    my $function = $cgi->param('func');
    my $user     = $cgi->param('user');

    if ($function && $user && $prot)
    {
	if ($user =~ /master:(.*)/)
	{
	    $userR = $1;
	    $fig->assign_function($prot,"master",$function,"");
	    $fig->add_annotation($prot,$userR,"Set master function to\n$function\n");
	}
	else
	{
	    $fig->assign_function($prot,$user,$function,"");
	    $fig->add_annotation($prot,$user,"Set function to\n$function\n");
	}
    }
    $cgi->delete("request");
    $cgi->delete("func");
    &show_initial($fig,$cgi,$html,$prot);
}

sub view_annotations {
    my($fig,$cgi,$html,$prot) = @_;

    my $col_hdrs = ["who","when","annotation"];
    my $tab = [ map { [$_->[2],$_->[1],"<pre>" . $_->[3] . "<\/pre>"] } $fig->feature_annotations($prot) ];
    if (@$tab > 0)
    {
	push(@$html,&HTML::make_table($col_hdrs,$tab,"Annotations for $prot"));
    }
    else
    {
	push(@$html,"<h1>No Annotations for $prot</h1>\n");
    }
}

sub show_coupling_evidence {
    my($fig,$cgi,$html,$peg) = @_;
    my($pair,$peg1,$peg2,$link1,$link2);

    my $user = $cgi->param('user');
    my $to   = $cgi->param('to');
    my @coup = grep { $_->[1] eq $to } $fig->coupling_and_evidence($peg,5000,1.0e-20,0.1,"keep");

    if (@coup != 1) 
    {
	push(@$html,"<h1>Sorry, no evidence that $peg is coupled to $to</h1>\n");
    }
    else
    {
	my $col_hdrs = ["Peg1","Organism1","Function1","Peg2","Organism2","Function2"];
	my $tab = [];
	foreach $pair (@{$coup[0]->[2]})
	{
	    ($peg1,$peg2) = @$pair;
	    $link1 = &HTML::fid_link($cgi,$peg1);
	    $link2 = &HTML::fid_link($cgi,$peg2);
	    push(@$tab,[$link1,$fig->org_of($peg1),scalar $fig->function_of($peg1,$user),
			$link2,$fig->org_of($peg2),scalar $fig->function_of($peg2,$user)]);
	}
	push(@$html,&HTML::make_table($col_hdrs,$tab,"Evidence that $peg Is Coupled To $to"));
    }
}

sub psi_blast_prot_sequence {
    my($fig,$cgi,$prot_id) = @_;
}

sub show_initial {
    my($fig,$cgi,$html,$prot) = @_;

    my $gs = $fig->org_of($prot);
    push(@$html,"<h1>Protein $prot: $gs</h1>\n");
    if ($prot =~ /^fig\|\d+\.\d+\.peg/)
    {
	my $msg;
	if ($cgi->param('translate')) { $cgi->delete('translate'); $msg = "Turn Off Function Translation" }
	else                          { $cgi->param(-name => 'translate', -value => 1); $msg = "Translate Function Assignments" }
	my $url  = $cgi->self_url();
	my $link = "<a href=\"$url\">$msg</a><br>\n";
	push(@$html,$link);
	if ($cgi->param('translate')) { $cgi->delete('translate') }
	else                          { $cgi->param(-name => 'translate', -value => 1) }

	&display_peg($fig,$cgi,$html,$prot);
    }
    else
    {
#	&display_external($fig,$cgi,$html,$prot);
    }
}

sub display_peg {
    my($fig,$cgi,$html,$peg) = @_;
    my $loc;

    my $half_sz = 5000;

    if ($loc = $fig->feature_location($peg))
    {
	my($contig,$beg,$end) = &FIG::boundaries_of($loc);
	my $min = &FIG::max(0,&FIG::min($beg,$end) - $half_sz);
	my $max = &FIG::max($beg,$end) + $half_sz;
	my($feat,$min,$max) = $fig->genes_in_region(&FIG::genome_of($peg),$contig,$min,$max);

	&print_context($fig,$cgi,$html,$peg,$feat,$min,$max);
    }

    &print_assignments($fig,$cgi,$html,$peg);

    push(@$html,$cgi->hr);
    my $link = $cgi->self_url() . "&request=view_annotations";
    push(@$html,"<br><a href=$link>To View Annotations</a>\n");

    my $link = $cgi->self_url() . "&request=aa_sequence";
    push(@$html,"<br><a href=$link>Protein Sequence</a>\n");

    $link = $cgi->self_url() . "&request=dna_sequence";
    push(@$html,"<br><a href=$link>DNA Sequence</a>\n");

    $link = $cgi->url();
    $link =~ s/protein.cgi/fid_checked.cgi/;
    my $user = $cgi->param('user');
    if (! $user) 
    { 
	$user = "";
    }
    else
    {
	$link = $link . "?fid=$prot&user=$user&checked=$prot&assign/annotate=assign/annotate";
	push(@$html,"<br><a href=$link target=checked_window>To Make an Annotation</a>\n");
    }

    my $fc = $cgi->param('fc');
    if ((! $fc) && ($fig->feature_location($peg)))
    {
	my $link = $cgi->self_url() . "&fc=1";
	push(@$html,"<br><a href=$link>To Get Detailed Functional Coupling Data</a>\n");
    }
    elsif ($fc)
    {
	&print_fc($fig,$cgi,$html,$peg);
    }

    my $link = $cgi->self_url() . "&request=fusions";
    push(@$html,"<br><a href=$link>To Get Fusion Data</a>\n");

    my $sims = $cgi->param('sims');

    my $has_translation = $fig->translatable($peg);
    if ((! $cgi->param('compare_region')) && $has_translation)
    {
	my $link = $cgi->self_url() . "&compare_region=1";
	push(@$html,"<br><a href=$link>To Compare Region</a>\n");
    }
    elsif ($cgi->param('compare_region'))
    {
	&print_compared_regions($fig,$cgi,$html,$peg);
    }

    if ((! $sims) && $has_translation)
    {
	my $link = $cgi->self_url() . "&sims=1&maxN=5&expand_raw=1";
	push(@$html,"<br><a href=$link>To Get Similarities</a>\n");
    }
    elsif ($sims)
    {
	&print_similarities($fig,$cgi,$html,$peg);
    }

    if ($has_translation)
    {
	&show_tools($fig,$cgi,$html,$peg);
    }
}

################# Table-Driven Show Tools  ############################

sub show_tools {
    my($fig,$cgi,$html,$peg) = @_;

    $cgi->param(-name => "request",
		-value => "use_protein_tool");
    my $url = $cgi->self_url();

    if (open(TMP,"<$FIG_Config::global/LinksToTools"))
    {
	push(@$html,$cgi->hr);
	my $col_hdrs = ["Tool","Description"];
	my $tab = [];

	$/ = "\n//\n";
	while (defined($_ = <TMP>))
	{
	    my($tool,$desc) = split(/\n/,$_);
	    push(@$tab,["<a href=\"$url\&tool=$tool\">$tool</a>",$desc]);
	}
	close(TMP);
	$/ = "\n";
	push(@$html,&HTML::make_table($col_hdrs,$tab,"Tools to Analyze Protein Sequences"));
    }
    $cgi->delete('request');
}

################# Functional Coupling  ############################

sub print_fc {
    my($fig,$cgi,$html,$peg) = @_;
    my($sc,$neigh);
    
    my $user  = $cgi->param('user');
    my @tab   = map { ($sc,$neigh) = @$_;
		      [&ev_link($cgi,$neigh,$sc),$neigh,scalar $fig->function_of($neigh,$user)] 
		    } 
                $fig->coupling_and_evidence($peg,5000,1.0e-20,0.5,"keep");
    if (@tab > 0)
    {
	push(@$html,"<hr>\n");
	my $col_hdrs = ["Score","Peg","Function"];
	push(@$html,&HTML::make_table($col_hdrs,\@tab,"Functional Coupling"));
    }
}

sub ev_link {
    my($cgi,$neigh,$sc) = @_;

    my $prot = $cgi->param('prot');
    my $link = $cgi->url() . "?request=show_coupling_evidence&prot=$prot&to=$neigh";
    return "<a href=$link>$sc</a>";
}

################# Assignments  ############################

sub trans_function_of {
    my($cgi,$fig,$peg,$user) = @_;

    if (wantarray())
    {
	my $x;
	my @funcs = $fig->function_of($peg);
	if ($cgi->param('translate'))
	{
	    @funcs = map { $x = $_; $x->[1] = $fig->translate_function($x->[1]); $x } @funcs;
	}
	return @funcs;
    }
    else
    {
	my $func = $fig->function_of($peg,$user);
	if ($cgi->param('translate'))
	{
	    $func = $fig->translate_function($func);
	}
	return $func;
    }
}

sub print_assignments {
    my($fig,$cgi,$html,$peg) = @_;
    my($who,$func,$ec,@ecs,@tmp,$id,$i,$master_func,$user_func,$x);

    my $user = $cgi->param('user');
    my @funcs    = map { [$peg,@$_] } &trans_function_of($cgi,$fig,$peg);

    for ($i=0; ($i < @funcs) && ($funcs[$i]->[1] ne "master"); $i++) {}
    if ($i < @funcs)
    {
	$master_func = $funcs[$i]->[2];
    }
    else
    {
	$master_func = "";
    }

    for ($i=0; ($i < @funcs) && ($funcs[$i]->[1] ne $user); $i++) {}
    if ($i < @funcs)
    {
	$user_func = $funcs[$i]->[2];
    }
    else
    {
	$user_func = $master_func;
    }
    push(@$html,$cgi->h2("Current Assignment: $peg: $user_func"));
    my @maps_to  = grep { $_ ne $peg } map { $_->[0] } $fig->mapped_prot_ids($peg);
    @funcs = ();
    foreach $id (@maps_to)
    {
	if (($id ne $peg) && (@tmp = &trans_function_of($cgi,$fig,$id)) && (@tmp > 0))
	{
	    push(@funcs, map { $x = $_; [$id,@$_] } @tmp);
	}
    }
    @funcs = map { ($_->[1] eq "master") ? [$_->[0],"",$_->[2]] : $_ } @funcs;
    push(@$html,"<hr>\n");

    if ((@funcs == 0) && (! $user_func))
    {
	push(@$html,$cgi->h1("No function has been assigned"));
    }
    elsif (@funcs > 0)
    {
	my $col_hdrs = ["Id","Organism","Who","ASSIGN","Assignment"];
	my $title    = "Assignments for Essentially Identical Proteins";
	my $tab = [ map { ($id,$who,$func) = @$_; [ &HTML::set_prot_links($cgi,$id),$fig->org_of($id),$who,($user ? &assign_link($cgi,$func,$user_func) : ""), &set_map_links($fig,&FIG::genome_of($peg),$func)] } @funcs ];
        push(@$html,&HTML::make_table($col_hdrs,$tab,$title));
    }

#    $_ = join("",map { $_->[1] } @funcs);
#    @ecs = ($_ =~ /\d\.\d+\.\d+\.\d+/g);
#    foreach $ec (@ecs)
#    {
#	my $kegg_link = &HTML::kegg_link($ec);
#	push(@$html,"<br>$kegg_link<br>\n");
#    }
}



################# Similarities  ############################


sub print_similarities {
    my($fig,$cgi,$html,$peg) = @_;
    my($maxN,$maxP,$expand_groups,$ex_checked);

    my $user = $cgi->param('user');
    $user = $user ? $user : "";
    my $current_func = &trans_function_of($cgi,$fig,$peg,$user);

    if (! ($maxN   = $cgi->param('maxN')))
    {
	$maxN = 5;
    }
    
    if (! ($maxP   = $cgi->param('maxP')))
    {
	$maxP = 1.0e-5;
    }

    if ($expand_groups = 1) # $cgi->param('expand_groups'))
    {
	$ex_checked = "checked";
    }
    else
    {
	$ex_checked = "";
    }


    my $ex_raw = $cgi->param('expand_raw');
    if ($expand_groups = 1) # $cgi->param('expand_groups'))
    {
	$ex_checked = "checked";
    }
    else
    {
	$ex_checked = "";
    }

    push(@$html,"<hr>\n");

    push(@$html, $cgi->h1('Similarities'),
                 $cgi->start_form(-action => "protein.cgi"),
	         $cgi->hidden(-name => 'prot', -value => $peg),
	         $cgi->hidden(-name => 'sims', -value => 1),
	         $cgi->hidden(-name => 'fid', -value => $peg),
	         $cgi->hidden(-name => 'user', -value => $user),
	         $cgi->submit('more similarities'),
	         "MaxN: ", $cgi->textfield(-name => 'maxN', -size => 5, -value => 2 * $maxN, -override => 1),
	         "MaxP: ", $cgi->textfield(-name => 'maxP', -size => 10, -value => $maxP),
	         $cgi->checkbox(-name => 'expand_raw', -value => 1, -checked => $ex_raw, -label => "Expand Raw Sims"),
#	         "Expand Groups: ", $cgi->checkbox(-name => 'expand_groups', -value => 1, -checked => $ex_checked, -override => 1),
	         $cgi->end_form,

	         $cgi->hr
	 );

    my(@sims);
    @sims = $fig->sims($peg,$maxN,$maxP,$ex_raw ? "all" : "raw");

    if (@sims)
    {

	my @from = $cgi->radio_group(-name => 'from',
				     -nolabels => 1,
	                             -override => 1,
				     -values => ["",$peg,map { $_->id2 } @sims]);

	my $target = "window$$";
	push(@$html,
                 $cgi->start_form(-method => 'post',
				  -target => $target,
				  -action => 'fid_checked.cgi'
				  ),
	         $cgi->hidden(-name => 'fid', -value => $peg),
	         $cgi->hidden(-name => 'user', -value => $user),
	         $cgi->br,
	         "CHECKED: ", $cgi->submit('align'), 
	                      $cgi->submit('view annotations'),$cgi->submit('show regions'));
	if ($cgi->param('user'))
	{
	    push(@$html,$cgi->br,$cgi->br,
		        "<a href=$FIG_Config::cgi_url/Html/help_for_assignments_and_rules.html>Help on Assignments, Rules, and Checkboxes</a>",
		        $cgi->br,$cgi->br,$cgi->submit('assign/annotate'));
	    if ($cgi->param('translate'))
	    {
		push(@$html,$cgi->submit('add rules'),$cgi->submit('check rules'),$cgi->br);
	    }
	}
	push(@$html,
	         $cgi->br,
	         $cgi->checkbox(-name => 'checked', -value => $peg, -checked => 1,-override => 1),
	         $cgi->br
	     );

	if ($user)
	{
	    push(@$html,"No selected ASSIGN from/Translate to: ",shift @from,
		        $cgi->br,,
		        "ASSIGN From/Translate To: ",shift @from);
	}

	my $col_hdrs = ["ASSIGN To<br>---------<br>Translate from","family","size","Against","sc","region in similar sequence","region in $peg","ASSIGN From<br>-----------<br>translate to","Function","Organism","Aliases"];
	my $tab      = [];
	my $title    = "Similarities";
    
	foreach $_ (@sims)
	{
	    my($psc,$sim,$family,$sz,$funcF,$id2);
	    if ($expand_groups)
	    {
		$sim = $_;
		$psc = $sim->psc;
		$id2   = $sim->id2;
		if (($id2 =~ /^fig\|/) && ($family = $fig->in_family($id2)))
		{
		    $sz     = $fig->sz_family($family);
		    $funcF  = $fig->family_function($family);
		}
		else
		{
		    $sz = $funcF = "";
		}
	    }
	    else
	    {
		($psc,$sim,$family,$sz,$funcF) = @$_;
	    }
	    my $ln1   = $sim->ln1;
	       $id2   = $sim->id2;
	    my $ln2   = $sim->ln2;
	    my $b1    = $sim->b1;
	    my $e1    = $sim->e1;
	    my $b2    = $sim->b2;
	    my $e2    = $sim->e2;
	    my $d1    = abs($e1 - $b1) + 1;
	    my $d2    = abs($e2 - $b2) + 1;
	    my $reg1  = "$b1-$e1 (<b>$d1/$ln1</b>)";
	    my $reg2  = "$b2-$e2 (<b>$d2/$ln2</b>)";
            my $func2 = &trans_function_of($cgi,$fig,$id2,$cgi->param('user'));
	    if (defined($family))
	    {
		if ($funcF ne $func2)
		{
		    $func2 = "$funcF<br>$func2";
		}
	    }
	    else
	    {
		$sz     = "";
		$family = "";
	    }

	    my $check = $fig->translatable($id2) ?
		        qq(<input type="checkbox" name="checked" value="$id2">) : "";

            my $aliases = join(",",$fig->feature_aliases($id2));

	    my $assign_link = &assign_link($cgi,$func2,$current_func);
	    my $id2_link = &HTML::set_prot_links($cgi,$id2);
	    my $org = $fig->org_of($id2);

	    my $assign = $user ? shift @from : "";
	    push(@$tab,[$check,&HTML::family_link($family,$user),$sz,$id2_link,$psc,$reg2,$reg1,$assign, $func2,$org,$aliases]);
	}
	push(@$html,&HTML::make_table($col_hdrs,$tab,$title,["nowrap"]));
	push(@$html,$cgi->end_form);
    }
}


################# Context on the Chromosome ############################

sub print_context {
    my($fig,$cgi,$html,$peg,$feat,$beg,$end) = @_;
    my($contig1,$beg1,$end1,$strand,$max_so_far,$gap,$comment,$fc,$aliases);
    my($why_related,$fid1,$sz,$color,$map,$gg,$n,$link,$in_neighborhood);

    $why_related = "";
    my %in_cluster = map { $_ => 1 } $fig->in_cluster_with($peg);;

    my $col_hdrs = ["fid","starts","ends","size","","gap","fc","neigh","comment","aliases","Related"];
    my($tab) = [];
    my $genes = [];
    
    my $user = $cgi->param('user');
    my $peg_function = &trans_function_of($cgi,$fig,$peg,$user);

    my($role,$role1,%related_roles);
    foreach $role (&FIG::roles_of_function($peg_function))
    {
	foreach $role1 ($fig->neighborhood_of_role($role))
	{
	    $related_roles{$role1} = 1;
	}
    }

    foreach $fid1 (@$feat)
    {
	$fc = $in_cluster{$fid1} ? &pin_link($cgi,$fid1) : "";
	$aliases = $fig->feature_aliases($fid1);
	($contig1,$beg1,$end1) = $fig->boundaries_of(scalar $fig->feature_location($fid1));;
	$strand = ($beg1 < $end1) ? "+" : "-";

	if     ($fid1 eq $peg)    { $color = "green" }
	elsif  ($fc)              { $color = "blue" }
	else                      { $color = "red" }

	if ($fid1 =~ /peg\.(\d+)$/)
	{
	    $n = $1;
	    $link = $cgi->url() . "?prot=$fid1&user=$user";
	}
	elsif ($fid1 =~ /\.([a-z]+)\.\d+$/)
	{
	    $n = uc $1;
	    $link = "";
	}
	else
	{
	    $n ="";
	    $link = "";
	}
	    
	push(@$genes,[&FIG::min($beg1,$end1),&FIG::max($beg1,$end1),($strand eq "+") ? "rightArrow" : "leftArrow", $color,$n,$link]);
	if ($max_so_far)
	{
	    $gap = (&FIG::min($beg1,$end1) - $max_so_far) - 1;
	}
	else
	{
	    $gap = "";
	}
	$max_so_far = &FIG::max($beg1,$end1);
	
	
	$in_neighborhood = "";
	if (&FIG::ftype($fid1) eq "peg")
	{
	    $comment = &trans_function_of($cgi,$fig,$fid1,$user);
	    foreach $role (&FIG::roles_of_function($comment))
	    {
		if ($related_roles{$role})
		{
		    $in_neighborhood = "*";
		}
	    }
	}
	else
	{
	    $comment = "";
	}
	$comment = &set_map_links($fig,&FIG::genome_of($fid1),$comment);
	$sz = abs($end1-$beg1)+1;

	push(@$tab,[&HTML::fid_link($cgi,$fid1,"local"),$beg1,$end1,$sz,$strand,$gap,$fc,$in_neighborhood,
                    $comment,$aliases,$why_related]);
    }
    $map = ["",$beg,$end,$genes];
    $gg = [$map];
    push(@$html,&HTML::make_table($col_hdrs,$tab,"Context on the Chromosome"));
    push(@$html,@{ &GenoGraphics::render($gg,700,4,0,1) });
    return;
}

sub assign_link {
    my($cgi,$func,$existing_func) = @_;
    my($assign_url,$assign_link);

    if ($func && ((! $existing_func) || ($existing_func ne $func)))
    {
	$cgi->delete('request');
	$assign_url  = $cgi->self_url() . "&request=fast_assign&func=$func";  ## must encode
	$assign_link = "<a href=\"$assign_url\">&nbsp;<=&nbsp;</a>";
    }
    else
    {
	$assign_link = "";
    }
    return $assign_link;
}

sub pin_link {
    my($cgi,$peg) = @_;
    my $user = $cgi->param('user');
    $user = defined($user) ? $user : "";

    my $cluster_url  = &FIG::cgi_url . "/chromosomal_clusters.cgi?prot=$peg&user=$user";
    my $cluster_link = "<a href=\"$cluster_url\">*</a>";
    return $cluster_link;
}

sub set_map_links {
    my($fig,$org,$func) = @_;

    if ($func =~ /^(.*)(\d+\.\d+\.\d+\.\d+)(.*)$/)
    {
	my $before = $1;
	my $ec     = $2;
	my $after  = $3;
	return &set_map_links($fig,$org,$before) . &set_ec_to_maps($fig,$org,$ec) . &set_map_links($fig,$org,$after);
    }
    return $func;
}

sub set_ec_to_maps {
    my($fig,$org,$ec) = @_;

    my @maps = $fig->ec_to_maps($ec);
    if (@maps > 0)
    {
	$cgi->delete('request');
	my $url  = $cgi->self_url() . "&request=ec_to_maps&ec=$ec&org=$org";
	my $link = "<a href=\"$url\">$ec</a>";
	return $link;
    }
    return $ec;
}

sub show_ec_to_maps {
    my($fig,$cgi,$html,$ec) = @_;

    my $ec = $cgi->param('ec');
    if (! $ec)
    {
	push(@$html,$cgi->h1("Missing EC number"));
	return;
    }

    my @maps = $fig->ec_to_maps($ec);
    if (@maps > 0)
    {
	my $col_hdrs = ["map","metabolic topic"];
	my $map;
	my $tab      = [map { $map = $_; [&map_link($cgi,$map),$fig->map_name($map)] } @maps];
	push(@$html,&HTML::make_table($col_hdrs,$tab,"$ec: " . $fig->ec_name($ec)));
    }
}

sub map_link {
    my($cgi,$map) = @_;

    $cgi->delete('request');
    my $url  = $cgi->self_url() . "&request=link_to_map&map=$map";
    my $link = "<a href=\"$url\">$map</a>";
    return $link;
}

sub link_to_map {
    my($fig,$cgi,$html) = @_;

    my $map = $cgi->param('map');
    if (! $map)
    {
	push(@$html,$cgi->h1("Missing Map"));
	return;
    }

    my $org = $cgi->param('org');
    if (! $org)
    {
	push(@$html,$cgi->h1("Missing Org Parameter"));
	return;
    }
    my$user = $cgi->param('user');
    $user = $user ? $user : "";

    $ENV{"REQUEST_METHOD"} = "GET";
    $ENV{"QUERY_STRING"} = "user=$user&map=$map&org=$org";
    my @out = `./show_kegg_map.cgi`;
    &HTML::trim_output(\@out);
    push(@$html,@out);
}
	    
sub aa_sequence {
    my($fig,$cgi,$html,$prot) = @_;
    my($seq,$func,$i);

    if ($seq = $fig->get_translation($prot))
    {
	$func = $fig->function_of($prot,$cgi->param('user'));
	push(@$html,$cgi->pre,">$prot $func\n");
	for ($i=0; ($i < length($seq)); $i += 60)
	{
	    if ($i > (length($seq) - 60))
	    {
		push(@$html,substr($seq,$i) . "\n");
	    }
	    else
	    {
		push(@$html,substr($seq,$i,60) . "\n");
	    }
	}
	push(@$html,$cgi->end_pre);
    }
    else
    {
	push(@$html,$cgi->h1("No translation available for $prot"));
    }
}

sub dna_sequence {
    my($fig,$cgi,$html,$fid) = @_;
    my($seq,$func,$i);

    if ($seq = $fig->dna_seq($fig->genome_of($fid),scalar $fig->feature_location($fid)))
    {
	$func = $fig->function_of($prot,$cgi->param('user'));
	push(@$html,$cgi->pre,">$fid $func\n");
	for ($i=0; ($i < length($seq)); $i += 60)
	{
	    if ($i > (length($seq) - 60))
	    {
		push(@$html,substr($seq,$i) . "\n");
	    }
	    else
	    {
		push(@$html,substr($seq,$i,60) . "\n");
	    }
	}
	push(@$html,$cgi->end_pre);
    }
    else
    {
	push(@$html,$cgi->h1("No DNA sequence available for $fid"));
    }
}
	             
sub show_fusions {
    my($fig,$cgi,$html,$prot) = @_;

    $ENV{"REQUEST_METHOD"} = "GET";
    $ENV{"QUERY_STRING"} = "peg=$prot";
    my @out = `./fusions.cgi`;
    print join("",@out);
    exit;
}

sub print_compared_regions {
    my($fig,$cgi,$html,$peg) = @_;

    my @closest_pegs = &closest_pegs($fig,$peg,5);
    if (@closest_pegs > 0)
    {
	if ($fig->possibly_truncated($peg))
	{
	    push(@closest_pegs,&possible_extensions($peg,\@closest_pegs));
	}
	unshift(@closest_pegs,$peg);
	@closest_pegs = $fig->sort_fids_by_taxonomy(@closest_pegs);
	my @all_pegs = ();
	my $gg = &build_maps($fig,\@closest_pegs,\@all_pegs);
	my $color_sets = &cluster_genes(\@all_pegs,$peg);
	&set_colors_text_and_links($gg,\@all_pegs,$color_sets);
	push(@$html,@{ &GenoGraphics::render($gg,700,4,0,2) });
    }
}

sub closest_pegs {
    my($fig,$peg,$n) = @_;
    my($id2,$d,$peg2,$i);

    my @closest = map { $id2 = $_->id2; ($id2 =~ /^fig\|/) ? $id2 : () } $fig->sims($peg,5,1.0e-20,"all");

    if (@closest > $n) { $#closest = $n-1 }
    my %closest = map { $_ => 1 } @closest;
    my @pinned_to = grep { $_ ne $peg} $fig->in_pch_pin_with($peg);
    my $g1 = &FIG::genome_of($peg);
    @pinned_to = 
	map {$_->[1] }
	sort { $a->[0] <=> $b->[0] }
	map { $peg2 = $_; $d = $fig->crude_estimate_of_distance($g1,&FIG::genome_of($peg2)); [$d,$peg2] }
	@pinned_to;

    for ($i=0; ($i < @pinned_to) && ($i < $n); $i++)
    {
	$closest{$pinned_to[$i]} = 1;
    }
    return return keys(%closest);
}

sub build_maps {
    my($fig,$pinned_pegs,$all_pegs) = @_;
    my($gg,$loc,$contig,$beg,$end,$mid,$min,$max,$genes,$feat,$fid);
    my($contig1,$beg1,$end1,$map,$peg);

    $gg = [];
    foreach $peg (@$pinned_pegs)
    {
	$loc = $fig->feature_location($peg);
	($contig,$beg,$end) = &FIG::boundaries_of($loc);
	if ($contig && $beg && $end)
	{
	    $mid = int(($beg + $end) / 2);
	    $min = $mid - 8000;
	    $max = $mid + 8000;
	    $genes = [];
	    ($feat,undef,undef) = $fig->genes_in_region(&FIG::genome_of($peg),$contig,$min,$max);
	    foreach $fid (@$feat)
	    {
		($contig1,$beg1,$end1) = &FIG::boundaries_of(scalar $fig->feature_location($fid));
		$beg1 = &in_bounds($min,$max,$beg1);
		$end1 = &in_bounds($min,$max,$end1);
		push(@$genes,[&FIG::min($beg1,$end1),
			      &FIG::max($beg1,$end1),
			      ($beg1 < $end1) ? "rightArrow" : "leftArrow",
			      "grey",
			      "",
			      $fid]);

		if ($fid =~ /peg/)
		{
		    push(@$all_pegs,$fid);
		}
	    }
	    $map = [&FIG::abbrev($fig->org_of($peg)),0,$max+1-$min,
		    ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)];
	    push(@$gg,$map);
	}
    }
    return $gg;
}

sub in {
    my($x,$xL) = @_;
    my($i);

    for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}
    return ($i < @$xL);
}

sub in_bounds {
    my($min,$max,$x) = @_;

    if     ($x < $min)     { return $min }
    elsif  ($x > $max)     { return $max }
    else                   { return $x   }
}

sub decr_coords {
    my($genes,$min) = @_;
    my($gene);

    foreach $gene (@$genes)
    {
	$gene->[0] -= $min;
	$gene->[1] -= $min;
    }
    return $genes;
}

sub flip_map {
    my($genes,$min,$max) = @_;
    my($gene);
    
    foreach $gene (@$genes)
    {
	($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);
	$gene->[2] = ($gene->[2] eq "rightArrow") ? "leftArrow" : "rightArrow";
    }
    return $genes;
}

sub cluster_genes {
    my($all_pegs,$peg) = @_;
    my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);

    my @color_sets = ();

    $conn = &get_connections_by_similarity($all_pegs);
    for ($i=0; ($i < @$all_pegs); $i++)
    {
	if ($all_pegs->[$i] eq $peg) { $pegI = $i }
	if (! $seen{$i})
	{
	    $cluster = [$i];
	    $seen{$i} = 1;
	    for ($j=0; ($j < @$cluster); $j++)
	    {
		$x = $conn->{$cluster->[$j]};
		foreach $k (@$x)
		{
		    if (! $seen{$k})
		    {
			push(@$cluster,$k);
			$seen{$k} = 1;
		    }
		}
	    }

	    if ((@$cluster > 1) || ($cluster->[0] eq $pegI))
	    {
		push(@color_sets,$cluster);
	    }
	}
    }
    for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}
    $red_set = $color_sets[$i];
    splice(@color_sets,$i,1);
    @color_sets = sort { @$b <=> @$a } @color_sets;
    unshift(@color_sets,$red_set);

    my $color_sets = {};
    for ($i=0; ($i < @color_sets); $i++)
    {
	foreach $x (@{$color_sets[$i]})
	{
	    $color_sets->{$all_pegs->[$x]} = $i;
	}
    }
    return $color_sets;
}

sub get_connections_by_similarity {
    my($all_pegs) = @_;
    my($i,$tmp,$peg1,%peg2i,%pos_of);

    for ($i=0; ($i < @$all_pegs); $i++)
    {
	$tmp = $fig->maps_to_id($all_pegs->[$i]);
	push(@{$pos_of{$tmp}},$i);             # map the representative in nr to subscript in all_pegs
	if ($tmp ne $all_pegs->[$i])
	{
	    push(@{$pos_of{$all_pegs->[$i]}},$i);
	}
    }

    my($sim,%conn,$x,$y);
    for ($i=0; ($i < @$all_pegs); $i++)
    {
	foreach $sim ($fig->sims($all_pegs->[$i],500,1.0e-5,"raw"))
	{
	    if (defined($x = $pos_of{$sim->id2}))
	    {
		foreach $y (@$x)
		{
		    push(@{$conn{$i}},$y);
		}
	    }
	}
    }
    return \%conn;
}

sub set_colors_text_and_links {
    my($gg,$all_pegs,$color_sets) = @_;
    my($map,$gene,$peg,$color);

    foreach $map (@$gg)
    {
	foreach $gene (@{$map->[3]})
	{
	    $peg = $gene->[5];
	    if (defined($color = $color_sets->{$peg}))
	    {
		$gene->[3] = "color$color";
		$gene->[4] = $color + 1;
	    }
	    $gene->[5] = &peg_url($cgi,$peg);
	}
    }
}

sub peg_url {
    my($cgi,$peg) = @_;

    my $prot = $cgi->param('prot');
    $cgi->delete('prot');
    my $url  = $cgi->self_url() . "&prot=$peg&compare_region=1";
    $cgi->delete('prot');
    $cgi->param(-name => 'prot', -value => $prot);

    return $url;
}    

sub possible_extensions {
    my($peg,$closest_pegs) = @_;
    my($g,$sim,$id2,$peg1,%poss);

    $g = &FIG::genome_of($peg);

    foreach $peg1 (@$closest_pegs)
    {
	if ($g ne &FIG::genome_of($peg1))
	{
	    foreach $sim ($fig->sims($peg1,500,1.0e-5,"all"))
	    {
		$id2 = $sim->id2;
		if (($id2 ne $peg) && ($id2 =~ /^fig\|$g\./) && $fig->possibly_truncated($id2))
		{
		    $poss{$id2} = 1;
		}
	    }
	}
    }
    return keys(%poss);
}

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3