Parent Directory
| 
Revision Log
Revision 1.1 - (view) (download)
| 1 : | paczian | 1.1 | # |
| 2 : | # Copyright (c) 2003-2006 University of Chicago and Fellowship | ||
| 3 : | # for Interpretations of Genomes. All Rights Reserved. | ||
| 4 : | # | ||
| 5 : | # This file is part of the SEED Toolkit. | ||
| 6 : | # | ||
| 7 : | # The SEED Toolkit is free software. You can redistribute | ||
| 8 : | # it and/or modify it under the terms of the SEED Toolkit | ||
| 9 : | # Public License. | ||
| 10 : | # | ||
| 11 : | # You should have received a copy of the SEED Toolkit Public License | ||
| 12 : | # along with this program; if not write to the University of Chicago | ||
| 13 : | # at info@ci.uchicago.edu or the Fellowship for Interpretation of | ||
| 14 : | # Genomes at veronika@thefig.info or download a copy from | ||
| 15 : | # http://www.theseed.org/LICENSE.TXT. | ||
| 16 : | # | ||
| 17 : | |||
| 18 : | use strict; | ||
| 19 : | use warnings; | ||
| 20 : | |||
| 21 : | use CGI; | ||
| 22 : | use URI::Escape; | ||
| 23 : | use Data::Dumper; | ||
| 24 : | |||
| 25 : | use FIG; | ||
| 26 : | use FIG_CGI; | ||
| 27 : | use FIG_Config; | ||
| 28 : | use FigWebServices::SeedComponents; | ||
| 29 : | use GenoGraphics; | ||
| 30 : | |||
| 31 : | eval { | ||
| 32 : | &main; | ||
| 33 : | }; | ||
| 34 : | |||
| 35 : | if ($@) | ||
| 36 : | { | ||
| 37 : | my $cgi = new CGI(); | ||
| 38 : | |||
| 39 : | print $cgi->header(); | ||
| 40 : | print $cgi->start_html(); | ||
| 41 : | |||
| 42 : | # print out the error | ||
| 43 : | print $@; | ||
| 44 : | |||
| 45 : | print $cgi->end_html(); | ||
| 46 : | |||
| 47 : | } | ||
| 48 : | |||
| 49 : | sub main { | ||
| 50 : | my ($fig, $cgi, $user) = FIG_CGI::init(debug_save => 0, | ||
| 51 : | debug_load => 0, | ||
| 52 : | print_params => 0); | ||
| 53 : | my $peg = $cgi->param('prot') || "fig|83333.1.peg.4"; | ||
| 54 : | my $parameters = { fig_object => $fig, | ||
| 55 : | peg_id => $peg, | ||
| 56 : | table_style => 'plain', | ||
| 57 : | fig_disk => $FIG_Config::fig_disk . "/", | ||
| 58 : | form_target => 'region.cgi', | ||
| 59 : | title => "$peg Region", | ||
| 60 : | user => "" }; | ||
| 61 : | |||
| 62 : | print $cgi->header(); | ||
| 63 : | |||
| 64 : | print js(); | ||
| 65 : | |||
| 66 : | print FigWebServices::SeedComponents::Framework::get_plain_header($parameters); | ||
| 67 : | |||
| 68 : | my $gg = get_gg_data($peg, $fig, $cgi); | ||
| 69 : | foreach (@{&GenoGraphics::render($gg,700,4,0,2)}) { | ||
| 70 : | print; | ||
| 71 : | } | ||
| 72 : | |||
| 73 : | print "</body></html>"; | ||
| 74 : | |||
| 75 : | } | ||
| 76 : | |||
| 77 : | sub js { | ||
| 78 : | my $html_path = "./Html"; | ||
| 79 : | |||
| 80 : | return qq~<script src="$html_path\/css\/FIG.js" type="text/javascript"></script>~; | ||
| 81 : | } | ||
| 82 : | |||
| 83 : | sub get_gg_data { | ||
| 84 : | my ($peg, $fig, $cgi) = @_; | ||
| 85 : | |||
| 86 : | my $sz_region = 16000; | ||
| 87 : | |||
| 88 : | my $gg = []; | ||
| 89 : | my $loc = $fig->feature_location($peg); | ||
| 90 : | my ($contig,$beg,$end) = $fig->boundaries_of($loc); | ||
| 91 : | my $all_pegs; | ||
| 92 : | if ($contig && $beg && $end) { | ||
| 93 : | my $mid = int(($beg + $end) / 2); | ||
| 94 : | my $min = int($mid - ($sz_region / 2)); | ||
| 95 : | my $max = int($mid + ($sz_region / 2)); | ||
| 96 : | my $genes = []; | ||
| 97 : | my ($feat,undef,undef) = $fig->genes_in_region($fig->genome_of($peg),$contig,$min,$max); | ||
| 98 : | foreach my $fid (@$feat) { | ||
| 99 : | my $user = "master"; | ||
| 100 : | my ($contig1,$beg1,$end1) = $fig->boundaries_of($fig->feature_location($fid)); | ||
| 101 : | $beg1 = &in_bounds($min,$max,$beg1); | ||
| 102 : | $end1 = &in_bounds($min,$max,$end1); | ||
| 103 : | my $aliases = join( ', ', $fig->feature_aliases($fid) ); | ||
| 104 : | my $function = $fig->function_of($fid,$user); | ||
| 105 : | my ( $uniprot ) = $aliases =~ /(uni\|[^,]+)/; | ||
| 106 : | my $info = join('<br/>', "<b>PEG:</b> $fid", | ||
| 107 : | "<b>Contig:</b> $contig1", | ||
| 108 : | "<b>Begin:</b> $beg1", | ||
| 109 : | "<b>End:</b> $end1", | ||
| 110 : | $function ? "<b>Function:</b> $function" : (), | ||
| 111 : | $uniprot ? "<b>Uniprot ID:</b> $uniprot" : () | ||
| 112 : | ); | ||
| 113 : | |||
| 114 : | my $sprout = $cgi->param('SPROUT') ? 1 : ""; | ||
| 115 : | |||
| 116 : | my $fmg = "<a href=\"region.cgi?prot=$fid\">show</a>"; | ||
| 117 : | |||
| 118 : | my $shape = "Rectangle"; | ||
| 119 : | if (($fid !~ /\.bs\./) && ($beg1 < $end1)) { $shape = "rightArrow" } | ||
| 120 : | elsif (($fid !~ /\.bs\./) && ($beg1 > $end1)) { $shape = "leftArrow" } | ||
| 121 : | |||
| 122 : | push(@$genes,[$fig->min($beg1,$end1), | ||
| 123 : | $fig->max($beg1,$end1), | ||
| 124 : | $shape, | ||
| 125 : | ($fid ne $peg) ? "grey" : 'red', | ||
| 126 : | "", | ||
| 127 : | $fid, | ||
| 128 : | $info, $fmg]); | ||
| 129 : | |||
| 130 : | if ($fid =~ /peg/) { | ||
| 131 : | push(@$all_pegs,$fid); | ||
| 132 : | } | ||
| 133 : | } | ||
| 134 : | |||
| 135 : | # Sequence title can be replaced by [ title, url, popup_text, menu, popup_title ] | ||
| 136 : | my $org = $fig->org_of($peg); | ||
| 137 : | my $desc = "Genome: $org<br />Contig: $contig"; | ||
| 138 : | my $map = [ [ FIG::abbrev( $org ), undef, $desc, undef, 'Contig' ], | ||
| 139 : | 0, | ||
| 140 : | $max+1 - $min, | ||
| 141 : | ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max) | ||
| 142 : | ]; | ||
| 143 : | push(@$gg,$map); | ||
| 144 : | } | ||
| 145 : | &GenoGraphics::disambiguate_maps($gg); | ||
| 146 : | return $gg; | ||
| 147 : | } | ||
| 148 : | |||
| 149 : | sub flip_map { | ||
| 150 : | my($genes,$min,$max) = @_; | ||
| 151 : | my($gene); | ||
| 152 : | |||
| 153 : | foreach $gene (@$genes) { | ||
| 154 : | ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]); | ||
| 155 : | if ($gene->[2] eq "rightArrow") { $gene->[2] = "leftArrow" } | ||
| 156 : | elsif ($gene->[2] eq "leftArrow") { $gene->[2] = "rightArrow" } | ||
| 157 : | } | ||
| 158 : | return $genes; | ||
| 159 : | } | ||
| 160 : | |||
| 161 : | sub in_bounds { | ||
| 162 : | my($min,$max,$x) = @_; | ||
| 163 : | |||
| 164 : | if ($x < $min) { return $min } | ||
| 165 : | elsif ($x > $max) { return $max } | ||
| 166 : | else { return $x } | ||
| 167 : | } | ||
| 168 : | |||
| 169 : | sub decr_coords { | ||
| 170 : | my($genes,$min) = @_; | ||
| 171 : | my($gene); | ||
| 172 : | |||
| 173 : | foreach $gene (@$genes) { | ||
| 174 : | $gene->[0] -= $min; | ||
| 175 : | $gene->[1] -= $min; | ||
| 176 : | } | ||
| 177 : | return $genes; | ||
| 178 : | } | ||
| 179 : | |||
| 180 : | sub in { | ||
| 181 : | my($x,$xL) = @_; | ||
| 182 : | my($i); | ||
| 183 : | |||
| 184 : | for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {} | ||
| 185 : | return ($i < @$xL); | ||
| 186 : | } |
| MCS Webmaster | ViewVC Help |
| Powered by ViewVC 1.0.3 |