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

View of /FigWebServices/wc.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (download) (annotate)
Sun May 11 23:17:30 2014 UTC (5 years, 7 months ago) by overbeek
Branch: MAIN
initial copy

#!/usr/bin/env /vol/ross/FIGdisk/bin/run_perl

BEGIN {
    unshift @INC, qw(
              /homes/overbeek/Ross/MakeCS.Kbase/bin
              /homes/overbeek/Ross/JoseERmodel/Take2
              /vol/ross/FIGdisk/dist/releases/dev/FigKernelPackages
              /vol/ross/FIGdisk/dist/releases/dev/common/lib
              /vol/ross/FIGdisk/dist/releases/dev/common/lib/FigKernelPackages
              /vol/ross/FIGdisk/dist/releases/dev/common/lib/WebApplication
              /vol/ross/FIGdisk/dist/releases/dev/common/lib/FortyEight
              /vol/ross/FIGdisk/dist/releases/dev/common/lib/PPO
              /vol/ross/FIGdisk/dist/releases/dev/common/lib/RAST
              /vol/ross/FIGdisk/dist/releases/dev/common/lib/MGRAST
              /vol/ross/FIGdisk/dist/releases/dev/common/lib/SeedViewer
              /vol/ross/FIGdisk/dist/releases/dev/common/lib/ModelSEED
              /vol/ross/FIGdisk/dist/anon/common/lib
              /vol/ross/FIGdisk/dist/anon/common/lib/FigKernelPackages
              /vol/ross/FIGdisk/config
 
);
}
use FIG;
my $fig = new FIG;

use Data::Dumper;
use Carp;
use FIG_Config;
$ENV{'BLASTMAT'} = "/vol/ross/FIGdisk/BLASTMAT";
$ENV{'FIG_HOME'} = "/vol/ross/FIGdisk";
# end of tool_hdr
########################################################################
use CGI;


if (-f "$FIG_Config::data/Global/why_down")
{
    local $/;
    open my $fh, "<$FIG_Config::data/Global/why_down";
    my $down_msg = <$fh>;
    
    print CGI::header();
    print CGI::head(CGI::title("SEED Server down"));
    print CGI::start_body();
    print CGI::h1("SEED Server down");
    print CGI::p("The seed server is not currently running:");
    print CGI::pre($down_msg);
    print CGI::end_body();
    exit;
}

if ($FIG_Config::readonly)
{
    CGI::param("user", undef);
}
########################################################################
use CGI;


if (-f "$FIG_Config::data/Global/why_down")
{
    local $/;
    open my $fh, "<$FIG_Config::data/Global/why_down";
    my $down_msg = <$fh>;
    
    print CGI::header();
    print CGI::head(CGI::title("SEED Server down"));
    print CGI::start_body();
    print CGI::h1("SEED Server down");
    print CGI::p("The seed server is not currently running:");
    print CGI::pre($down_msg);
    print CGI::end_body();
    exit;
}

if ($FIG_Config::readonly)
{
    CGI::param("user", undef);
}
########################################################################
# -*- 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 URI::Escape;  # uri_escape
use gjoseqlib;
use HTML;
use strict;
use CGI;
my $cgi = new CGI;
use SeedEnv;
use tree_utilities;
use CloseStrains;

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

my $html     = [];

my $node     = $cgi->param('node');
my $family   = $cgi->param('family');
my $ali      = $cgi->param('alignment');
my $tree     = $cgi->param('tree');
my $request  = $cgi->param('request');
my $keywords = $cgi->param('keywords');
my $function = $cgi->param('function');
my $dataD    = $cgi->param('dataD');
my $csD  = "/homes/overbeek/Ross/MakeCS.Kbase/Data/CS";
my $dataDF  = "$csD/$dataD";

if ($request eq "show_otus")
{
    &show_otus($cgi,$csD);
    exit;
}
elsif (($request eq "show_options_for_otu") && $dataD)
{
    $html = &CloseStrains::show_options_for_otu($cgi,$dataD);
}
elsif ($request eq "show_signatures")
{
    &CloseStrains::show_signatures($cgi,$dataDF,$html);
}
elsif ($request eq "compute_sigs")
{
    &CloseStrains::compute_signatures($cgi,$dataDF,$html);
}
elsif (($request eq "show_func") && $function)
{
    $function =~ s/^\s+//;
    $function =~ s/\s+$//;
    &CloseStrains::show_func($cgi,$dataDF,$html,$function);
}
elsif (($request eq "show_family_pegs") && $family)
{
    &CloseStrains::show_family_pegs($cgi,$dataDF,$html,$family);
}
elsif (($request eq "show_virulence_functions") && (-s "$dataDF/virulence.functions"))
{
    &show_virulence_functions($cgi,$dataDF,$html);
}
elsif (($request eq 'show_indexed_funcs') && $keywords)
{
    &show_indexed_funcs($cgi,$dataDF,$html,$keywords); 
}
elsif (($request eq "show_ali_or_occurs_tree") && $ali)
{
    &CloseStrains::show_ali($cgi,$dataDF);  # NOTE: the alignment invokes Gary's alignment viewer,
                                            # which prints the header, so we print everything in show_ali
    exit;
}
elsif (($request eq "show_ali_or_occurs_tree") && $tree)
{
    &CloseStrains::show_occurs_tree($cgi,$dataDF,$html);
}
elsif (($request eq "show_family_tree") && $family)
{
    &CloseStrains::show_family_tree($cgi,$dataDF,$html,$family);
}
elsif (($request eq "show_node") && $node)
{
    &show_changes($cgi,$dataDF,$html,$node);
}
elsif ($request eq "show_otu_tree")
{
    &CloseStrains::show_otu_tree($cgi,$dataDF,$html,'families');
}
elsif ($request eq "show_adjacency")
{
    &CloseStrains::show_otu_tree($cgi,$dataDF,$html,'adjacency');
}
elsif ($request eq "show_clusters")
{
    &show_clusters($cgi,$dataDF,$html);
}
else
{
    push(@$html,"<h1>Invalid request</h1>");
}
&HTML::show_page($cgi,$html);
exit;

sub show_changes {
    my($cgi,$dataDF,$html,$node) = @_;

    my $type = $cgi->param('type');
    if ($type eq 'families')
    {
	&show_changes_families($cgi,$dataDF,$html,$node);
    }
    else
    {
	&show_changes_adjacency($cgi,$dataDF,$html,$node);
    }
}

sub show_changes_adjacency {
    my($cgi,$dataDF,$html,$node) = @_;
    $dataDF =~ /([^\/]+)$/; 
    my $dataD = $1;
    my $col_hdrs = ['Family','Function','Ancestral','New','Compare'];
    my @events = grep { $node eq $_->[1] } 
                 map { ($_ =~ /(\S+)\t(\S+)\t(\d+):\S+\t(\d+):\S+\t(\d+)/) ? [$1,$2,$3,$4,$5] : () }
                 `cat $dataDF/placed.events`;
    my %families = map { ($_->[2] => [$_->[3],$_->[4]])} @events;
    my %pegs_needed  = map { (($_->[2] => 1), ($_->[3] => 1),($_->[4] => 1)) } @events;
    my %fam_peg  = map { my $x; 
			 (($_ =~ /^(\d+)\t\S+\t(\d+)\t\S+\t\S+\t(\S+)\t(\S+)/) && 
		          ($x = $families{$1}) && (($x->[0] eq $2) || ($x->[1] eq $2))) ? ("$1,$2" => $3) : () }
                   `cat $dataDF/adjacency.of.unique`;
    my %peg_to_func = map { (($_ =~ /^([^t]+)\t([^\t]*)\t(\S+)/) && $pegs_needed{$1}) ? ($3 => $2) : () } `cut -f1,2,4 $dataDF/families.all`;
    my @rows;
    my $ancestor;
    foreach my $event (@events)
    {
	my($anc,$node,$fam,$fam1,$fam2) = @$event;
	$ancestor = $anc;
	my $peg1 = $fam_peg{"$fam,$fam1"};
	my $peg2 = $fam_peg{"$fam,$fam2"};
	my $func = $peg_to_func{$peg1};
	if ($peg1 && $peg2 && $func)
	{
	    push(@rows,[&CloseStrains::show_fam_table_link($dataDF,$fam),
			$func,
			&CloseStrains::peg_link($peg1),
			&CloseStrains::peg_link($peg2),
	                &compare_link([$peg1,$peg2])]);
	}
    }
    push(@$html,&HTML::make_table($col_hdrs,\@rows,"Changes in Adjacency from $ancestor"));
}


sub show_changes_families {
    my($cgi,$dataDF,$html,$node) = @_;

    $dataDF =~ /([^\/]+)$/; 
    my $dataD = $1;

    my %func = map { ($_ =~ /^(\d+)\t(\S[^\t]*\S)/) ? ($1 => $2) : () } `cut -f1,2 $dataDF/families.all`;
    my $col_hdrs = ['Show Where','Show PEGs','Family','Function','Clusters','Coupling'];
    my @tmp = grep { (($_ =~ /^\S+\t(\S+)/) && ($1 eq $node)) } 
              `cat /$dataDF/where.shifts.occurred`;
    my @tabG  = sort { ($a->[4] cmp $b->[4]) or ($a->[3] <=> $b->[3]) }
	        map { ($_ =~ /^(\S+)\t\S+\t(\S+)\t0\t1/) ? [&CloseStrains::show_fam_links($dataDF,$2),$1,$2,$func{$2}] : () } 
                @tmp;
    # tabG entries are [linkT,linkP,ancestor,fam,func]

    # try to pick up the ancestor node from the first entry in @tabG
    # If you cannot get it, try to take it from @tabL
    my $anc = (@tabG > 0) ? $tabG[0]->[-3] : undef;
    foreach $_ (@tabG) { splice(@$_,2,1) }   ### get rid of ancestor
    ## tabG entries are [linkT,linkP,fam,func]

    my @tabL  = sort { ($a->[4] cmp $b->[4]) or ($a->[3] <=> $b->[3]) }
	        map { ($_ =~ /^(\S+)\t\S+\t(\S+)\t1\t0/) ? [&CloseStrains::show_fam_links($dataDF,$2),$1,$2,$func{$2}] : () } 
                @tmp;
    if (! $anc)
    {
	$anc = (@tabL > 0) ? $tabL[0]->[-3] : '';
    }
    foreach $_ (@tabL) { splice(@$_,2,1) }   ### get rid of ancestor

## @tabG and @tabL are of the form [link-to-tree,link-to-peg-display,family,function]]
## we now add coupling data.

    my $with_couplingL = &build_table(\@tabL,$dataDF);
    my $with_couplingG = &build_table(\@tabG,$dataDF);
    
    push(@$html,&HTML::make_table($col_hdrs,$with_couplingG,"Families Gained from Ancestor $anc"),$cgi->hr,"\n");
    push(@$html,&HTML::make_table($col_hdrs,$with_couplingL,"Families Lost from Ancestor $anc"),$cgi->hr,"\n");
}


sub build_table {
    my($tab,$dataDF) = @_;
    $dataDF =~ /([^\/]+)$/; 
    my $dataD = $1;

    my %famH = map { ($_->[-2] => 1) } @$tab;
    my %fam_to_func = map { ($_->[2] => $_->[3]) } @$tab;
    my $coupledH = &CloseStrains::coupling_data($dataDF,\%famH);
    my @with_coupling;
    foreach my $tuple (@$tab)
    {
	my($link1,$link2,$family,$function) = @$tuple;
	$tuple->[3] = &CloseStrains::show_func_link($dataD,$function);
	my($cluster_link,$coupled_html) = &CloseStrains::cluster_link_and_cluster_html($family,$coupledH,\%fam_to_func,$dataD);
	$tuple->[4] = $cluster_link;
	$tuple->[5] = $coupled_html; 
	push(@with_coupling,$tuple);
    }
    return \@with_coupling;
}



sub show_indexed_funcs {
    my($cgi,$dataDF,$html,$keywords) = @_;

    $dataDF =~ /([^\/]+)$/; 
    my $dataD = $1;

    my $functions_in_fams = &functions_in_at_least_one_family($dataDF);
#    $keywords = "$dataD " . $keywords; ### tell the user to add it,if necessary

    my %funcs_to_show;

    foreach my $func (`svr_sphinx_indexing -k \'$keywords\' | cut -f1 | svr_function_of | cut -f2`)
    {
	chomp $func;
	$func =~ s/\s*\#.*$//;
	if ($functions_in_fams->{$func})
	{
	    $funcs_to_show{$func}++;
	}
    }
    my @funcs = sort { $funcs_to_show{$b} <=> $funcs_to_show{$a} } keys(%funcs_to_show);
    if (@funcs == 0)
    {
	push(@$html,"<h1>Sorry, no functions matched</h1>\n");
    }
    else
    {
	my @links = map { [&CloseStrains::show_func_link($dataD,$_)] } @funcs;
	push(@$html,&HTML::make_table(['Possible Functions'],\@links,"Possible functions - Select to find nodes where shifts occurred"));
    }
}

sub show_virulence_functions {
    my($cgi,$dataDF,$html) = @_;

    $dataDF =~ /([^\/]+)$/; 
    my $dataD = $1;

    my $functions_in_fams = &functions_in_at_least_one_family($dataDF);
    my @virulence_functions = map { chomp; $functions_in_fams->{$_} ? $_ : () } `cat $dataDF/virulence.functions`;
    my @links = map { [&CloseStrains::show_func_link($dataD,$_)] } sort @virulence_functions;
    push(@$html,&HTML::make_table(['Function Sometimes Associated with Virulence'],
				  \@links,
				  'Functions Known to Be Associated with Virulence in Some Organisms'));
}
sub functions_in_at_least_one_family {
    my($dataDF) = @_;

    my %functions_in_fams = map { chomp; ($_ => 1) }  `cut -f2 $dataDF/families.all`;
    return \%functions_in_fams;
}

sub subsystems_of {
    my($fig,$reaction_to_roles,$reaction) = @_;

    my $roles_and_pegs = $reaction_to_roles->{$reaction};
    my @roles          = map { my $x = $_; $x =~ s/^[^:]+://; $x } @{$reaction_to_roles->{$reaction}};
    my $printable_roles = "";
    if (@roles > 0)
    { 
	my %tmp = map { $_ =~ /^([^:]+):(\S.*\S)/; ($2 => $1) } @$roles_and_pegs;
	my @tmp = map { &CloseStrains::peg_link($tmp{$_}) . "<br>" . $_ } sort keys(%tmp);
	$printable_roles = join(",",@tmp);
    }
    my %subsys;
    foreach my $role (@roles)
    {
	foreach my $s ($fig->role_to_subsystems($role))
	{
	    $subsys{$s} = 1;
	}
    }
    return join("\t",sort keys(%subsys)) . "<br>" . $printable_roles;
}


sub show_otus {
    my($cgi,$datadir) = @_;

    print $cgi->header;
    if (opendir(GENERA,$csD))
    {
	my @genera = grep { $_ !~ /^\./ } readdir(GENERA);
	closedir(GENERA);
	print "<h1>What Changed?</h1>\n";
	print "<h2><a target=_blank href=\"http://bioseed.mcs.anl.gov/~overbeek/what_changed.html\">Getting Started: a short Tutorial</a></h2>\n";
	print "<h2>Genera Available</h2>\n";
	foreach my $g (sort @genera)
	{
	    print "<h3><a target=_blank href=http://bioseed.mcs.anl.gov/ross/FIG/wc.cgi?request=show_options_for_otu&dataD=$g>$g</a>\n";
	}
    }
    else
    {
	print "<h1>The dataD parameter is invalid\n";
    }
}

sub compare_link {
    my($pegs) = @_;
    my @genomes = map { ($_ =~ /^fig\|(\d+\.\d+)/) ? $1 : () } @$pegs;
    my $args = join("&",map { "show_genome=$_" } @genomes);
    return "<a target=_blank href=http://pubseed.theseed.org/seedviewer.cgi?page=Annotation&feature=" .
	     $pegs->[0] . "&$args>Compare Regions</a>";
}


sub virulence_functions_link {
    my($cgi,$dataDF) = @_;

    if ((-s "$dataDF/virulence.functions") && ($dataDF =~ /([^\/]+)$/))
    {
	my $dataDQ = uri_escape($1);
	return "<a target=_blank href=http://bioseed.mcs.anl.gov/ross/FIG/wc.cgi?request=show_virulence_functions&dataD=$dataDQ>Some Posssible Functions Associated with Virulence</a>";
    }
    return '';
}

sub show_clusters {
    my($cgi,$dataDF,$html) = @_;

    my $families = $cgi->param('families');
    my @families = split(/,/,$families);
    my %families = map { $_ => 1 } @families;
    my %genome_names = map { ($_ =~ /^(\S+)\t(\S.*\S)/) ? ($1 => $2) : () } `cat $dataDF/genome.names`;
    my @genome_pegN_fam_func = sort { ($a->[0] <=> $b->[0]) or ($a->[1] <=> $b->[1]) }
	                       map { (($_ =~ /^(\S+)\t([^\t]*)\t[^\t]*\tfig\|(\d+\.\d+)\.peg\.(\d+)/) && $families{$1}) ?
					 [$3,$4,$1,$2] : () 
                                   } `cat $dataDF/families.all`;
    push(@$html,$cgi->h1('Relevant Clusters'));
    my $col_hdrs = ['Family','Function','PEG'];
    my $last = shift @genome_pegN_fam_func;
    while ($last)
    {
	my $last_g    = $last->[0];
	my $last_pegN = $last->[1];
	my @set;
	while ($last && ($last_g == $last->[0]) && &close($last_pegN,$last->[1]))
	{
	    $last_pegN = $last->[1];
	    push(@set,[$last->[2],$last->[3],&CloseStrains::peg_link("fig|" . $last_g . ".peg." . $last_pegN)]);
	    $last = shift @genome_pegN_fam_func;
	}
	if (@set > 1)
	{
	    push(@$html,&HTML::make_table($col_hdrs,\@set,"Cluster for $last_g: $genome_names{$last_g}"));
	    push(@$html,"<hr><br><br>\n");
	}
    }
}

sub close {
    my($pegN1,$pegN2) = @_;

    return abs($pegN2 - $pegN1) <= 7;
}


MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3