Parent Directory
| 
Revision Log
Revision 1.3 - (view) (download)
| 1 : | overbeek | 1.1 | # -*- perl -*- |
| 2 : | # | ||
| 3 : | # Copyright (c) 2003-2008 University of Chicago and Fellowship | ||
| 4 : | # for Interpretations of Genomes. All Rights Reserved. | ||
| 5 : | # | ||
| 6 : | # This file is part of the SEED Toolkit. | ||
| 7 : | # | ||
| 8 : | # The SEED Toolkit is free software. You can redistribute | ||
| 9 : | # it and/or modify it under the terms of the SEED Toolkit | ||
| 10 : | # Public License. | ||
| 11 : | # | ||
| 12 : | # You should have received a copy of the SEED Toolkit Public License | ||
| 13 : | # along with this program; if not write to the University of Chicago | ||
| 14 : | # at info@ci.uchicago.edu or the Fellowship for Interpretation of | ||
| 15 : | # Genomes at veronika@thefig.info or download a copy from | ||
| 16 : | # http://www.theseed.org/LICENSE.TXT. | ||
| 17 : | # | ||
| 18 : | |||
| 19 : | |||
| 20 : | use strict; | ||
| 21 : | use Data::Dumper; | ||
| 22 : | |||
| 23 : | use FIG; | ||
| 24 : | use FIG_CGI; | ||
| 25 : | |||
| 26 : | use URI::Escape; # uri_escape | ||
| 27 : | use HTML; | ||
| 28 : | my $fig = new FIG; | ||
| 29 : | use CGI; | ||
| 30 : | my $cgi = new CGI; | ||
| 31 : | |||
| 32 : | if (0) | ||
| 33 : | { | ||
| 34 : | print $cgi->header; | ||
| 35 : | my @params = $cgi->param; | ||
| 36 : | print "<pre>\n"; | ||
| 37 : | foreach $_ (@params) | ||
| 38 : | { | ||
| 39 : | print "$_\t:",join(",",$cgi->param($_)),":\n"; | ||
| 40 : | } | ||
| 41 : | exit; | ||
| 42 : | } | ||
| 43 : | |||
| 44 : | disz | 1.2 | my $subsys = "$FIG_Config::data/Subsystems"; |
| 45 : | #my $subsys = "/vol/core-seed/FIGdisk/FIG/Data/Subsystems"; | ||
| 46 : | overbeek | 1.1 | |
| 47 : | my $html = []; | ||
| 48 : | unshift @$html, "<TITLE>Subsystem-based compare-regions</TITLE>\n"; | ||
| 49 : | my $ss = $cgi->param('ss'); | ||
| 50 : | my $abbr = $cgi->param('abbr'); | ||
| 51 : | |||
| 52 : | if ((! $ss) || (! $abbr)) | ||
| 53 : | { | ||
| 54 : | push(@$html,"<h1> ERROR: You need to use ss= and abbr= parameters</h1>"); | ||
| 55 : | &HTML::show_page($cgi,$html); | ||
| 56 : | exit; | ||
| 57 : | } | ||
| 58 : | if (! -s "$subsys/$ss/spreadsheet") | ||
| 59 : | { | ||
| 60 : | push(@$html,"<h1> ERROR: No such subsystemp in coreSEED ($subsys)</h1>"); | ||
| 61 : | &HTML::show_page($cgi,$html); | ||
| 62 : | exit; | ||
| 63 : | } | ||
| 64 : | olson | 1.3 | my @pegs = &pegs_in_spreadsheet("$subsys/$ss",$abbr,$fig); |
| 65 : | overbeek | 1.1 | |
| 66 : | if (@pegs == 0) | ||
| 67 : | { | ||
| 68 : | push(@$html,"<h1> ERROR: No pegs in $abbr of $subsys</h1>"); | ||
| 69 : | &HTML::show_page($cgi,$html); | ||
| 70 : | exit; | ||
| 71 : | } | ||
| 72 : | |||
| 73 : | my $number_pegs = $cgi->param('n'); | ||
| 74 : | if (! $number_pegs) { $number_pegs = 10 } | ||
| 75 : | while (@pegs > 0) | ||
| 76 : | { | ||
| 77 : | my $sz = (@pegs > $number_pegs) ? $number_pegs : @pegs; | ||
| 78 : | my @batch = splice(@pegs,0,$sz); | ||
| 79 : | olson | 1.3 | my @bpegs = map { $_->[0] } @batch; |
| 80 : | my $start_href = &link(\@bpegs); | ||
| 81 : | my $start_link = "<a target=_blank href=$start_href>$batch[0]->[0] $batch[0]->[2]</a><br>\n"; | ||
| 82 : | overbeek | 1.1 | push(@$html,"<br><br>",$start_link,"<br>\n"); |
| 83 : | olson | 1.3 | |
| 84 : | push(@$html, "<a target=_blank href='$FIG_Config::cgi_url/seedviewer.cgi?feature=$_->[0]'>$_->[0]</a><br>\n") foreach @batch; | ||
| 85 : | |||
| 86 : | overbeek | 1.1 | } |
| 87 : | |||
| 88 : | &HTML::show_page($cgi,$html); | ||
| 89 : | |||
| 90 : | sub link { | ||
| 91 : | my($pegs) = @_; | ||
| 92 : | |||
| 93 : | my $features = join('&feature=',@$pegs); | ||
| 94 : | disz | 1.2 | return "$FIG_Config::cgi_url/seedviewer.cgi?page=Regions&feature=" . $features; |
| 95 : | #return "http://core.theseed.org/FIG/seedviewer.cgi?page=Regions&feature=" . $features; | ||
| 96 : | overbeek | 1.1 | } |
| 97 : | |||
| 98 : | sub pegs_in_spreadsheet { | ||
| 99 : | olson | 1.3 | my($ssF,$abbr,$fig) = @_; |
| 100 : | overbeek | 1.1 | |
| 101 : | my $spreadsheet = join("",`cat $ssF/spreadsheet`); | ||
| 102 : | my($hdrs,undef,$genomes) = split(/\n\/\/\n/,$spreadsheet); | ||
| 103 : | my @hdrs = map { ($_ =~ /^(\S+)/) ? $1 : () } split(/\n/,$hdrs); | ||
| 104 : | my $i; | ||
| 105 : | for ($i=0; ($i < @hdrs) && ($hdrs[$i] ne $abbr); $i++) {} | ||
| 106 : | my @pegs; | ||
| 107 : | foreach $_ (split(/\n/,$genomes)) | ||
| 108 : | { | ||
| 109 : | my @rows = split(/\t/,$_); | ||
| 110 : | my $g = shift @rows; | ||
| 111 : | shift @rows; # dump variant code | ||
| 112 : | push(@pegs,map { "fig|$g.peg.$_" } split(/,/,$rows[$i])); | ||
| 113 : | } | ||
| 114 : | olson | 1.3 | @pegs = grep { $fig->is_real_feature($_) } @pegs; |
| 115 : | my @tuples = map { [$_,$fig->taxonomy_of(&SeedUtils::genome_of($_)),$fig->genus_species(&SeedUtils::genome_of($_))] } @pegs; | ||
| 116 : | @tuples = sort { $a->[1] cmp $b->[1] } @tuples; | ||
| 117 : | #print STDERR Dumper(\@tuples); | ||
| 118 : | #return map { $_->[0] } @tuples; | ||
| 119 : | return @tuples; | ||
| 120 : | overbeek | 1.1 | } |
| MCS Webmaster | ViewVC Help |
| Powered by ViewVC 1.0.3 |