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

View of /FigWebServices/show_cffs.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (download) (annotate)
Thu Aug 5 18:49:50 2010 UTC (9 years, 5 months ago) by overbeek
Branch: MAIN
CVS Tags: mgrast_dev_08112011, mgrast_dev_08022011, rast_rel_2014_0912, myrast_rel40, mgrast_dev_05262011, mgrast_dev_04082011, rast_rel_2010_0928, mgrast_version_3_2, mgrast_dev_12152011, mgrast_dev_06072011, rast_rel_2014_0729, mgrast_dev_02212011, rast_rel_2010_1206, mgrast_release_3_0, mgrast_dev_03252011, rast_rel_2011_0119, mgrast_release_3_0_4, mgrast_release_3_0_2, mgrast_release_3_0_3, mgrast_release_3_0_1, mgrast_dev_03312011, mgrast_release_3_1_2, mgrast_release_3_1_1, mgrast_release_3_1_0, mgrast_dev_04132011, mgrast_dev_04012011, rast_rel_2010_0827, myrast_33, rast_rel_2011_0928, mgrast_dev_04052011, mgrast_dev_02222011, mgrast_dev_10262011, HEAD
show coupling between two FIGfams

#########################################################################
# -*- perl -*-
#
# Copyright (c) 2003-2006 University of Chicago and Fellowship
# for Interpretations of Genomes. All Rights Reserved.
#
# This file is part of the SEED Toolkit.
# 
# The SEED Toolkit is free software. You can redistribute
# it and/or modify it under the terms of the SEED Toolkit
# Public License. 
#
# You should have received a copy of the SEED Toolkit Public License
# along with this program; if not write to the University of Chicago
# at info@ci.uchicago.edu or the Fellowship for Interpretation of
# Genomes at veronika@thefig.info or download a copy from
# http://www.theseed.org/LICENSE.TXT.
#

use FIG;
my $fig = new FIG;

use DB_File;
use SSserver;
use SeedEnv;
use Data::Dumper;
use HTML;
use strict;

#my $url = "http://servers.nmpdr.org/pseed/sapling/server.cgi";
my $sapO = new SAPserver; # (  url => $url );

use CGI;
my $cgi = new CGI;

if (0)
{
    my $VAR1;
    eval(join("",`cat $FIG_Config::temp/showcffs_cgi`));
    $cgi = $VAR1;
#   print STDERR &Dumper($cgi);
}

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

    if (0)
    {
	if (open(TMP,">$FIG_Config::temp/show_cffs_cgi"))
	{
	    print TMP &Dumper($cgi);
	    close(TMP);
	}
    }
    exit;
}
my $html = [];
my $f1 = $cgi->param('f1');
my $f2 = $cgi->param('f2');


if (! ($f1 && $f2))
{
    push(@$html,$cgi->h2("You need to invoke this with f1= and f2=. <br>"));
}
else
{
    &show_connected_families($cgi,$sapO,$f1,$f2,$html);
}
&HTML::show_page($cgi,$html);
exit;

sub show_connected_families {
    my($cgi,$sapO,$f1,$f2,$html) = @_;

    my $n = $cgi->param('n');
    if (! $n) { $n = 50 }

    my $pegs1 = $sapO->figfam_fids( -id => $f1, -fasta => 0 );
    my $pegs2 = $sapO->figfam_fids( -id => $f2, -fasta => 0 );
    my @close_pairs = &close_pairs($sapO,$pegs1,$pegs2);
#    print STDERR &Dumper(\@close_pairs); die "aborted";
    my @pinned = map { $_->[0] } @close_pairs;
    my $url = &make_url(\@pinned,$n);
    print $cgi->redirect($url);
    exit;
}
sub close_pairs {
    my($sapO,$pegs1,$pegs2) = @_;

    my %pegs2 = map { $_ => 1 } @$pegs2;
    my @all = (@$pegs1,@$pegs2);
    my $locH = $sapO->fid_locations( -ids => \@all, -boundaries => 1 );    

    my @pegs_with_locs = sort { ($a->[1] cmp $b->[1]) or ($a->[2] <=> $b->[2]) }
                         map { my $peg = $_; my $loc = $locH->{$peg};
		         ($loc =~ /^(\d+\.\d+:\S+)_(\d+)([-+])(\d+)/) ? [$peg,$1,$2,$3,$4] : () } @all;

#    print STDERR &Dumper(\@pegs_with_locs);
    my @pairs = ();
    my $i;
    for ($i=0; ($i < (@pegs_with_locs - 1)); $i++)
    {
	my $j;
	for ($j=$i+1; ($j < @pegs_with_locs) && (&gap_sz($pegs_with_locs[$i],$pegs_with_locs[$j]) <= 5000); $j++)
	{
	    if ($pegs2{$pegs_with_locs[$i]->[0]} && (! $pegs2{$pegs_with_locs[$j]->[0]}))
	    {
#		print STDERR &Dumper(['pushing',$pegs_with_locs[$j],$pegs_with_locs[$i]]);
		push(@pairs,[$pegs_with_locs[$j]->[0],$pegs_with_locs[$i]->[0]]);
	    }
	    elsif (! $pegs2{$pegs_with_locs[$i]->[0]} && $pegs2{$pegs_with_locs[$j]->[0]})
	    {
#		print STDERR &Dumper(['pushing',$pegs_with_locs[$i],$pegs_with_locs[$j]]);
		push(@pairs,[$pegs_with_locs[$i]->[0],$pegs_with_locs[$j]->[0]]);
	    }
	}
    }
    return @pairs;
}

sub gap_sz {
    my($x,$y) = @_;

    if ($x->[1] ne $y->[1]) { return 1000000 }
    my $min = ($x->[3] eq "+") ? ($x->[2] + $x->[4]) : $x->[2];
    my $max = ($y->[3] eq "+") ? $y->[2] : ($y->[2] - $y->[4]);
    return abs($max - $min);
}

sub make_url {
    my($pegs,$n) = @_;

    my $uri = "http://pseed.theseed.org/seedviewer.cgi?page=Regions&feature=";
    my @tmp = @$pegs; 
    if (@tmp > $n)
    {
	$#tmp = $n-1;
	$pegs = \@tmp;
    }
    my $url  = $uri . join('&feature=',@$pegs);
    return $url;
}
 

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3