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

View of /FigWebServices/samples.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (download) (annotate)
Mon Dec 2 17:06:31 2013 UTC (6 years, 1 month ago) by overbeek
Branch: MAIN
CVS Tags: rast_rel_2014_0729, rast_rel_2014_0912, HEAD
Changes since 1.4: +8 -6 lines
progress

########################################################################
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 FIG;
my $fig = new FIG;

use HTML;
use strict;

use CGI;
my $cgi = new CGI;
if (0)
{
    my $VAR1;
    eval(join("",`cat /tmp/samples`));
    $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,">/tmp/samples"))
	{
	    print TMP &Dumper($cgi);
	    close(TMP);
	}
    }
    exit;
}
my $html     = [];
my $genome   = $cgi->param('genome');
my @samples  = $cgi->param('sample');
my $sample1  = (@samples > 0) ? $samples[0] : $cgi->param('sample1');
my $sample2  = (@samples > 1) ? $samples[1] : $cgi->param('sample2');
my $tablesD  = "/homes/overbeek/Ross/JoseERmodel/CGI/Organisms/224308.113/Tables";

if ($genome && (! $sample1) && (! $sample2))
{
    my @samples = `cat $tablesD/Sample.entity`;
    chop @samples;

    push(@$html,$cgi->start_form(-action => 'samples.cgi', -target => '_blank'),
	        $cgi->textfield( -name => "sample1", -size => 100 ),"<br>",
	        $cgi->textfield( -name => "sample2", -size => 100 ),"<br>",
	        $cgi->hidden(-name => 'genome', -value => $genome),
	        $cgi->submit('compare samples'),"<br>",
	        $cgi->end_form);
}
elsif ((! $genome) || (! $sample1))
{
    push(@$html,"<h3>Invalid parameters: 'genome' and 'sample1' must both be set</h3>");
}
elsif ($genome && $sample1 && $sample2)
{
    push(@$html,"<h1>Comparing $sample1 and $sample2 in genome $genome</h1>");
    &show2($fig,$cgi,$html,$genome,$tablesD,$sample1,$sample2);
}
elsif ($genome && $sample1)
{
    push(@$html,"<h1>Atomic Regulons in $sample1</h1>");
    &show1($fig,$cgi,$html,$genome,$tablesD,$sample1);
}

&HTML::show_page($cgi,$html);
exit;

sub show1 {
    my($fig,$cgi,$html,$genome,$tablesD,$sample1) = @_;

    my $parms = {};
    $parms->{genome} = $genome;
    $parms->{tables}  = $tablesD;

    &load_parms($parms);
    push(@$html,&show_atomic_regulons($sample1,$parms));
}

sub show_atomic_regulons {
    my($sample1,$parms) = @_;

    my @html = ();
    push(@html,&study($parms,$sample1),"<hr><br>");

    my $atomic_regulonsH = $parms->{sample2ar}->{$sample1};
    my @atomic_regulons  = keys(%$atomic_regulonsH);
    my $col_hdrs = ['Atomic Regulon','AR-Name','PEG','PEG-ON-OFF','Function'];
    my @rows;
    foreach my $ar (sort { $a <=> $b } @atomic_regulons)
    {
	if ($atomic_regulonsH->{$ar} == 1)
	{
	    my $ar_name = $parms->{ar_names}->{$ar} || '';
	    my $pegs = $parms->{ar2pegs}->{$ar};
	    foreach my $peg (sort { &SeedUtils::by_fig_id($a,$b) } @$pegs)
	    {
		my $func = $parms->{peg2func}->{$peg} || '';
		my $peg_on_off = $parms->{peg2sample}->{$peg}->{$sample1};
		push(@rows,[&atomic_regulon_links($parms,[$ar]),
			    $ar_name,
			    &peg_link($peg),
			    $peg_on_off,
			    $func]);
	    }
	}
    }
    push(@html,&HTML::make_table($col_hdrs,\@rows,"Atomic Regulons in $sample1"));
    return @html;
}

sub show2 {
    my($fig,$cgi,$html,$genome,$tablesD,$sample1,$sample2) = @_;

    my $parms = {};
    $parms->{genome} = $genome;
    $parms->{tables}  = $tablesD;

    &load_parms($parms);
    push(@$html,&study($parms,$sample1));
    push(@$html,&study($parms,$sample2),"<hr><br>");

    push(@$html,&comp_table($sample1,$sample2,$parms));
}

sub study {
    my($parms,$sample) = @_;

    my @html;
    my $study = $parms->{sample2study}->{$sample};
    my $tuple = $parms->{study}->{$study};
    my($desc,$explanation) = @$tuple;
    push(@html,"<h2>Study $study: $sample</h2>\n");
    push(@html,"<h3>Description</h3>$desc<br>");
    push(@html,"<h3>Explanation</h3>$explanation<br>");
    return @html;
}

sub comp_table {
    my($sample1,$sample2,$parms) = @_;
    
    my @pegs = keys(%{$parms->{peg2func}});
    my $sample1H = $parms->{sample2peg}->{$sample1};

    my $sample2H = $parms->{sample2peg}->{$sample2};
    my $genome = $parms->{genome};
    my $peg_to_stimulii = $parms->{peg2stimulii_links};
    my $col_hdrs = ['PEG','Stimulii','Atomic Regulon','AR-desc','Sample1','Sample2','Function'];
    my @rows;
    foreach my $peg (@pegs)
    {
	my $v1 = $sample1H->{$peg};
	my $v2 = $sample2H->{$peg};
	if (abs($v1-$v2) == 2)
	{
	    my $stims = &stim_links($parms,$peg);
	    my $func = $parms->{peg2func}->{$peg};
	    my $ars = $parms->{peg2ars}->{$peg};
	    my $ar_desc = defined($ars->[0]) ? $parms->{ar_names}->{$ars->[0]} : '';
	    push(@rows,[$peg,$stims,$ars,$ar_desc,$v1,$v2,$func]);
	}
    }
    @rows = sort { ($a->[4] <=> $b->[4]) or ($a->[2]->[0] cmp $b->[2]->[0]) } @rows;
    foreach my $row (@rows)
    {
	$row->[0] = &peg_link($row->[0]);
	$row->[2] = &atomic_regulon_links($parms,$row->[2]);
    }
    return &HTML::make_table($col_hdrs,\@rows,"PEGs That Shift Between $sample1 and $sample2");
}

sub load_parms {
    my($parms) = @_;

    my %funcH = map { ($_ =~ /^(fig\S+)\t(\S.*\S)/) ? ($1 => $2) : () } `echo $genome | svr_all_features peg | svr_function_of`;
    $parms->{peg2func} = \%funcH;

    my %peg2ar;
    my %ar2peg;
    foreach $_ (`cat $tablesD/PegToAr`)
    {
	if ($_ =~ /^(\d+)\t(\S+)/)
	{
	    push(@{$peg2ar{$2}},$1);
	    push(@{$ar2peg{$1}},$2);
	}
    }
    $parms->{peg2ars} = \%peg2ar;
    $parms->{ar2pegs} = \%ar2peg;

    my %stim2readable = map { ($_ =~ /^(\S+)\t(\S+)/) ? ($1 => $2) : () } `cat $tablesD/Stimulus.entity`;
    $parms->{stim2readable} = \%stim2readable;

    my %peg_linkH = map { ($_ =~ /^(\S+)\t(\S+)\t(\S+)/) ? ($1 => join(",",(&peg_link($1),$2,$3))) : &peg_link($1) } 
                    `cat $tablesD/aliases`;
    $parms->{peg2link} = \%peg_linkH;
    &peg_to_stimulii_links($parms);

    my %sample2peg;
    my %peg2sample;
    foreach $_ (`cat $tablesD/peg.on.off.calls`)
    {
	if ($_ =~ /^(\S+)\t(\S+)\t(\S+)/)
	{
	    $sample2peg{$1}->{$2} = $3;
	    $peg2sample{$2}->{$1} = $3;
	}
    }
    $parms->{sample2peg} = \%sample2peg;
    $parms->{peg2sample} = \%peg2sample;

    my $sample2ar = {};
    my $ar2sample = {};
    foreach $_ (`cat $tablesD/atomic.regulon.on.off.calls`)
    {
	if ($_ =~ /^(\S+)\t(\S+)\t(\S+)/)
	{
	    $sample2ar->{$1}->{$2} = $3;
	    $ar2sample->{$2}->{$1} = $3;
	}
    }
    $parms->{sample2ar} = $sample2ar;
    $parms->{ar2sample} = $ar2sample;

    my %ar_names = map { ($_ =~ /^(\d+)\t(\S.*\S)/) ? ($1 => $2) : () } `cat $tablesD/AR.entity`;
    $parms->{ar_names} = \%ar_names;

    my %exp_cond2study;
    my %study2exp_conds;
    foreach $_ (`cat $tablesD/Study-ExpCond`)
    {
	if ($_ =~ /^(\S+)\t(\S+)/)
	{
	    my($study,$exp_cond) = ($1,$2);
	    $exp_cond2study{$2} = $1;
	    push(@{$study2exp_conds{$study}},$exp_cond);
	}
    }
    $parms->{exp_cond2study}  = \%exp_cond2study;
    $parms->{study2exp_conds} = \%study2exp_conds;

    my %sample2study;
    my %study2samples;
    foreach $_ (`cat $tablesD/ExpCond-Sample`)
    {
	if ($_ =~ /(\S+)\t(\S+)/)
	{
	    my($exp_cond,$sample) = ($1,$2);
	    if (my $study = $exp_cond2study{$exp_cond})
	    {
		push(@{$study2samples{$study}},$sample);
		$sample2study{$sample} = $study;
	    }
	}
    }
    $parms->{sample2study}  = \%sample2study;
    $parms->{study2samples} = \%study2samples;

    my %study;
    foreach $_ (`cat $tablesD/Study.entity`)
    {
	chomp;
	my($study,$desc,$explanation) = split(/\t/,$_);
	$study{$study} = [$desc,$explanation];
    }
    $parms->{study} = \%study;
}


sub peg_link {
    my($peg) = @_;
    my $g = &SeedUtils::genome_of($peg);
    return "<a target=_blank href=peg.cgi?genome=$g&peg=$peg>$peg</a>";
}

sub stim_link {
    my($stim,$stimReal,$genome) = @_;
	    
    return "<a target=_blank href=stimulus.cgi?stimulus=$stim&genome=$genome>$stimReal</a>";
}

sub stim_links {
    my($parms,$peg) = @_;

    my $stims = $parms->{peg2stimulii_links}->{$peg};
    my $stim_links = "";
    if ($stims)
    {
	$stim_links = join(",",@$stims);
    }
    return $stim_links;
}


sub atomic_regulon_link {
    my($atomic_regulon,$genome) = @_;

    return "<a target=_blank href=atomic_regulon.cgi?atomic_regulon=$atomic_regulon&genome=$genome>$atomic_regulon</a>";
}

sub atomic_regulon_links {
    my($parms,$ars) = @_;

    if ((!$ars) || (@$ars == 0)) { return '' }
    my $genome = $parms->{genome};
    return join(",",map { &atomic_regulon_link($_,$genome) } @$ars);
}

sub peg_to_stimulii_links {
    my($parms) = @_;

    my $peg_to_stimulii = {};

    my %stimH = map { ($_ =~ /^(\S+)\t(\S+)/) ? ($1 => &stim_link($1,$2,$genome)) : () } `cat $tablesD/Stimulus.entity`;
    foreach $_ (`cat $tablesD/PegToStim`)
    {
	$_ =~ /^(\S+)\t(\S+)/;
	push(@{$peg_to_stimulii->{$1}},$stimH{$2});
    }
    $parms->{peg2stimulii_links} = $peg_to_stimulii;
}

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3