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

Diff of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1, Mon Dec 1 16:57:09 2003 UTC revision 1.2, Wed Dec 3 21:24:31 2003 UTC
# Line 1  Line 1 
1    #!/Users/fig/FIGdisk/env/mac/bin/perl
2    
3    #
4    # This file is automatically generated by configure-env
5    # Do not edit by hand, or changes may be lost.
6    #
7    
8    use Data::Dumper;
9    use Carp;
10    
11    use lib "/Users/fig/FIGdisk/FIG/Packages";
12    
13    use FIG_Config;
14    
15    
16  use FIG;  use FIG;
17  my $fig = new FIG;  my $fig = new FIG;
# Line 262  Line 276 
276      my $sims = $cgi->param('sims');      my $sims = $cgi->param('sims');
277    
278      my $has_translation = $fig->translatable($peg);      my $has_translation = $fig->translatable($peg);
279        if ((! $cgi->param('compare_region')) && $has_translation)
280        {
281            my $link = $cgi->self_url() . "&compare_region=1";
282            push(@$html,"<br><a href=$link>To Compare Region</a>\n");
283        }
284        elsif ($cgi->param('compare_region'))
285        {
286            &print_compared_regions($fig,$cgi,$html,$peg);
287        }
288    
289      if ((! $sims) && $has_translation)      if ((! $sims) && $has_translation)
290      {      {
291          my $link = $cgi->self_url() . "&sims=1&maxN=5&expand_raw=1";          my $link = $cgi->self_url() . "&sims=1&maxN=5&expand_raw=1";
# Line 683  Line 707 
707      $map = ["",$beg,$end,$genes];      $map = ["",$beg,$end,$genes];
708      $gg = [$map];      $gg = [$map];
709      push(@$html,&HTML::make_table($col_hdrs,$tab,"Context on the Chromosome"));      push(@$html,&HTML::make_table($col_hdrs,$tab,"Context on the Chromosome"));
710      push(@$html,@{ &GenoGraphics::render($gg,700,4) });      push(@$html,@{ &GenoGraphics::render($gg,700,4,0,1) });
711      return;      return;
712  }  }
713    
# Line 859  Line 883 
883      print join("",@out);      print join("",@out);
884      exit;      exit;
885  }  }
886    
887    sub print_compared_regions {
888        my($fig,$cgi,$html,$peg) = @_;
889    
890        my @closest_pegs = &closest_pegs($fig,$peg,5);
891        if (@closest_pegs > 0)
892        {
893            if ($fig->possibly_truncated($peg))
894            {
895                push(@closest_pegs,&possible_extensions($peg,\@closest_pegs));
896            }
897            unshift(@closest_pegs,$peg);
898            @closest_pegs = $fig->sort_fids_by_taxonomy(@closest_pegs);
899            my @all_pegs = ();
900            my $gg = &build_maps($fig,\@closest_pegs,\@all_pegs);
901            my $color_sets = &cluster_genes(\@all_pegs,$peg);
902            &set_colors_text_and_links($gg,\@all_pegs,$color_sets);
903            push(@$html,@{ &GenoGraphics::render($gg,700,4,0,2) });
904        }
905    }
906    
907    sub closest_pegs {
908        my($fig,$peg,$n) = @_;
909        my($id2,$d,$peg2,$i);
910    
911        my @closest = map { $id2 = $_->id2; ($id2 =~ /^fig\|/) ? $id2 : () } $fig->sims($peg,5,1.0e-20,"all");
912    
913        if (@closest > $n) { $#closest = $n-1 }
914        my %closest = map { $_ => 1 } @closest;
915        my @pinned_to = $fig->in_pch_pin_with($prot);
916        my $g1 = &FIG::genome_of($peg);
917        @pinned_to =
918            map {$_->[1] }
919            sort { $a->[0] <=> $b->[0] }
920            map { $peg2 = $_; $d = $fig->crude_estimate_of_distance($g1,&FIG::genome_of($peg2)); [$d,$peg2] }
921            @pinned_to;
922    
923        for ($i=0; ($i < @pinned_to) && ($i < $n); $i++)
924        {
925            $closest{$pinned_to[$i]} = 1;
926        }
927        return return keys(%closest);
928    }
929    
930    sub build_maps {
931        my($fig,$pinned_pegs,$all_pegs) = @_;
932        my($gg,$loc,$contig,$beg,$end,$mid,$min,$max,$genes,$feat,$fid);
933        my($contig1,$beg1,$end1,$map,$peg);
934    
935        $gg = [];
936        foreach $peg (@$pinned_pegs)
937        {
938            $loc = $fig->feature_location($peg);
939            ($contig,$beg,$end) = &FIG::boundaries_of($loc);
940            if ($contig && $beg && $end)
941            {
942                $mid = int(($beg + $end) / 2);
943                $min = $mid - 8000;
944                $max = $mid + 8000;
945                $genes = [];
946                ($feat,undef,undef) = $fig->genes_in_region(&FIG::genome_of($peg),$contig,$min,$max);
947                foreach $fid (@$feat)
948                {
949                    ($contig1,$beg1,$end1) = &FIG::boundaries_of(scalar $fig->feature_location($fid));
950                    $beg1 = &in_bounds($min,$max,$beg1);
951                    $end1 = &in_bounds($min,$max,$end1);
952                    push(@$genes,[&FIG::min($beg1,$end1),
953                                  &FIG::max($beg1,$end1),
954                                  ($beg1 < $end1) ? "rightArrow" : "leftArrow",
955                                  "grey",
956                                  "",
957                                  $fid]);
958    
959                    if ($fid =~ /peg/)
960                    {
961                        push(@$all_pegs,$fid);
962                    }
963                }
964                $map = [&FIG::abbrev($fig->org_of($peg)),0,$max+1-$min,
965                        ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)];
966                push(@$gg,$map);
967            }
968        }
969        return $gg;
970    }
971    
972    sub in {
973        my($x,$xL) = @_;
974        my($i);
975    
976        for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}
977        return ($i < @$xL);
978    }
979    
980    sub in_bounds {
981        my($min,$max,$x) = @_;
982    
983        if     ($x < $min)     { return $min }
984        elsif  ($x > $max)     { return $max }
985        else                   { return $x   }
986    }
987    
988    sub decr_coords {
989        my($genes,$min) = @_;
990        my($gene);
991    
992        foreach $gene (@$genes)
993        {
994            $gene->[0] -= $min;
995            $gene->[1] -= $min;
996        }
997        return $genes;
998    }
999    
1000    sub flip_map {
1001        my($genes,$min,$max) = @_;
1002        my($gene);
1003    
1004        foreach $gene (@$genes)
1005        {
1006            ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);
1007            $gene->[2] = ($gene->[2] eq "rightArrow") ? "leftArrow" : "rightArrow";
1008        }
1009        return $genes;
1010    }
1011    
1012    sub cluster_genes {
1013        my($all_pegs,$peg) = @_;
1014        my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);
1015    
1016        my @color_sets = ();
1017    
1018        $conn = &get_connections_by_similarity($all_pegs);
1019        for ($i=0; ($i < @$all_pegs); $i++)
1020        {
1021            if ($all_pegs->[$i] eq $peg) { $pegI = $i }
1022            if (! $seen{$i})
1023            {
1024                $cluster = [$i];
1025                $seen{$i} = 1;
1026                for ($j=0; ($j < @$cluster); $j++)
1027                {
1028                    $x = $conn->{$cluster->[$j]};
1029                    foreach $k (@$x)
1030                    {
1031                        if (! $seen{$k})
1032                        {
1033                            push(@$cluster,$k);
1034                            $seen{$k} = 1;
1035                        }
1036                    }
1037                }
1038    
1039                if ((@$cluster > 1) || ($cluster->[0] eq $pegI))
1040                {
1041                    push(@color_sets,$cluster);
1042                }
1043            }
1044        }
1045        for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}
1046        $red_set = $color_sets[$i];
1047        splice(@color_sets,$i,1);
1048        @color_sets = sort { @$b <=> @$a } @color_sets;
1049        unshift(@color_sets,$red_set);
1050    
1051        my $color_sets = {};
1052        for ($i=0; ($i < @color_sets); $i++)
1053        {
1054            foreach $x (@{$color_sets[$i]})
1055            {
1056                $color_sets->{$all_pegs->[$x]} = $i;
1057            }
1058        }
1059        return $color_sets;
1060    }
1061    
1062    sub get_connections_by_similarity {
1063        my($all_pegs) = @_;
1064        my($i,@tmp,$peg1,%peg2i,%pos_of);
1065    
1066        for ($i=0; ($i < @$all_pegs); $i++)
1067        {
1068            @tmp = $fig->mapped_prot_ids($all_pegs->[$i]);
1069            push(@{$pos_of{$tmp[0]->[0]}},$i);             # map the representative in nr to subscript in all_pegs
1070            if ($tmp[0]->[0] ne $all_pegs->[$i])
1071            {
1072                push(@{$pos_of{$all_pegs->[$i]}},$i);
1073            }
1074        }
1075    
1076        my($sim,%conn,$x,$y);
1077        for ($i=0; ($i < @$all_pegs); $i++)
1078        {
1079            foreach $sim ($fig->sims($all_pegs->[$i],500,1.0e-5,"raw"))
1080            {
1081                if (defined($x = $pos_of{$sim->id2}))
1082                {
1083                    foreach $y (@$x)
1084                    {
1085                        push(@{$conn{$i}},$y);
1086                    }
1087                }
1088            }
1089        }
1090        return \%conn;
1091    }
1092    
1093    sub set_colors_text_and_links {
1094        my($gg,$all_pegs,$color_sets) = @_;
1095        my($map,$gene,$peg,$color);
1096    
1097        foreach $map (@$gg)
1098        {
1099            foreach $gene (@{$map->[3]})
1100            {
1101                $peg = $gene->[5];
1102                if (defined($color = $color_sets->{$peg}))
1103                {
1104                    $gene->[3] = "color$color";
1105                    $gene->[4] = $color + 1;
1106                }
1107                $gene->[5] = &peg_url($cgi,$peg);
1108            }
1109        }
1110    }
1111    
1112    sub peg_url {
1113        my($cgi,$peg) = @_;
1114    
1115        my $prot = $cgi->param('prot');
1116        $cgi->delete('prot');
1117        my $url  = $cgi->self_url() . "&prot=$peg&compare_region=1";
1118        $cgi->delete('prot');
1119        $cgi->param(-name => 'prot', -value => $prot);
1120    
1121        return $url;
1122    }
1123    
1124    sub possible_extensions {
1125        my($peg,$closest_pegs) = @_;
1126        my($g,$sim,$id2,$peg1,%poss);
1127    
1128        $g = &FIG::genome_of($peg);
1129    
1130        foreach $peg1 (@$closest_pegs)
1131        {
1132            if ($g ne &FIG::genome_of($peg1))
1133            {
1134                foreach $sim ($fig->sims($peg1,500,1.0e-5,"all"))
1135                {
1136                    $id2 = $sim->id2;
1137                    if (($id2 ne $peg) && ($id2 =~ /^fig\|$g\./) && $fig->possibly_truncated($id2))
1138                    {
1139                        $poss{$id2} = 1;
1140                    }
1141                }
1142            }
1143        }
1144        return keys(%poss);
1145    }

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3