[Bio] / FigKernelScripts / Consistency_Families.pm Repository:
ViewVC logotype

View of /FigKernelScripts/Consistency_Families.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (download) (as text) (annotate)
Fri Mar 7 21:08:52 2008 UTC (11 years, 8 months ago) by bartels
Branch: MAIN
CVS Tags: mgrast_dev_08112011, rast_rel_2009_05_18, mgrast_dev_08022011, rast_rel_2014_0912, rast_rel_2008_06_18, myrast_rel40, rast_rel_2008_06_16, mgrast_dev_05262011, rast_rel_2008_12_18, mgrast_dev_04082011, rast_rel_2008_07_21, rast_rel_2010_0928, rast_2008_0924, mgrast_version_3_2, mgrast_dev_12152011, rast_rel_2008_04_23, mgrast_dev_06072011, rast_rel_2008_09_30, rast_rel_2009_0925, rast_rel_2010_0526, rast_rel_2014_0729, mgrast_dev_02212011, rast_rel_2010_1206, mgrast_release_3_0, mgrast_dev_03252011, rast_rel_2010_0118, mgrast_rel_2008_0924, mgrast_rel_2008_1110_v2, rast_rel_2009_02_05, rast_rel_2011_0119, mgrast_rel_2008_0625, 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, rast_rel_2008_10_09, mgrast_dev_04012011, rast_release_2008_09_29, mgrast_rel_2008_0806, mgrast_rel_2008_0923, mgrast_rel_2008_0919, rast_rel_2009_07_09, rast_rel_2010_0827, mgrast_rel_2008_1110, myrast_33, rast_rel_2011_0928, rast_rel_2008_09_29, mgrast_rel_2008_0917, rast_rel_2008_10_29, mgrast_dev_04052011, mgrast_dev_02222011, rast_rel_2009_03_26, mgrast_dev_10262011, rast_rel_2008_11_24, rast_rel_2008_08_07, HEAD
*** empty log message ***

#!/usr/bin/env /home/bartels/FIGdisk/env/cee/bin/perl

use FIG;
use Getopt::Std;

package Consistency_Families;

1;


sub compute_single_comparison_file {
    
    my ( $html, $seedurl, $pathemahash, $FamFunction, $FamsTOPEGs, $PegFunction, $idhash, $s, $FILTEROUT, $d, $y, $z, $o, $k, $t, $excel_link, $excel_link2 ) = @_;

    my $html_old = $html;
    open ( HTML, ">$html" );
    
    my $hdr = &print_html_hdr;
    print HTML $hdr;
    
    # $counter is the number of all CDSs #
    
    my $counter = 0;
    
    # $undefcounter is the number of CDSs that        # 
    # are not found in the file PegFunction->{ $peg } #
    
    my $undefcounter = 0;
    
    # $defcounter is the number of CDSs which are defined #
    
    my $defcounter = 0;
    
    # $overallconsistency will at the end be devided through the #
    # number of defined CDSs to get overall consistency          #
    
    my $overallconsistency = 0;
    
    # $overallaccuracy will at the end be devided through the #
    # number of defined CDSs to get overall accuracy          #
    
    my $overallaccuracy = 0;
    
    # As the websites are growing too large for as many families, #
    # I create a new one every $skip families. $familycounter     #
    # counts the families that have already been processed        #

    my $skip = 50;
    my $filecounter = 0;

    # If we have an excel_link, we wanna open that file here

    if ( defined( $excel_link ) ) {
	open( EXCEL, ">$excel_link2" );
	print EXCEL "Family\tFamily Function\tProtein ID\tProtein Function\n";
    }
    
    my %HTMLTEXTFORFAMILY;
#    print STDERR "HALLO\n";
    # go through tigrfams
    foreach my $tf ( sort keys %$FamsTOPEGs ) {

	# look if this tigrfam is to be filtered out
	if ( $FILTEROUT->{ $tf } ) {
	    next;
	}
	
	# hash for sets
	my %sets;
	
	foreach my $peg ( sort @{ $FamsTOPEGs->{ $tf } } ) {
	    
	    # if the peg can't be found in PegFunction it's undefined
	    if ( !defined( $PegFunction->{ $peg } ) ) {
	      print STDERR $peg." HERE NOT FOUND AAAHHH\n";
		$undefcounter++;
		next;
	    }
	    # if its defined count it
	    $defcounter++;
	
	    # if we have an excel link put a line in there
	    if ( defined( $excel_link ) ) {
		print EXCEL "$tf\t".$FamFunction->{ $tf }->{ 'function' }."\t$peg\t".$PegFunction->{ $peg }."\n";
	    }

    
	    # this part was put here for looking at the accuracy
	    # we test if the annotation of the peg is 'samefunc' to the family annotation
	    my ( $same ) = &SameFunc::same_func_why( $FamFunction->{ $tf }->{ 'function' }, $PegFunction->{ $peg }, $d );
	    
	    if ( $same ) {
		# if its the same count it for accuracy
		$overallaccuracy += 1;
	    }
	    
	    # now put the things into the sets
	    if ( !defined( $sets{ $PegFunction->{ $peg } } ) ) {
		
		# if the annotation does not exist yet, put it in there with a 1
		$sets{ $PegFunction->{ $peg } } = 1;
		
	    }
	    else {
		
		# else count it up
		$sets{ $PegFunction->{ $peg } } ++;
		
	    }
	    
	    my $htmltext = create_proteintable_html( $FamsTOPEGs->{ $tf }, $PegFunction, $FamFunction, $idhash, $seedurl, $d, $pathemahash );
	    $HTMLTEXTFORFAMILY{ $tf } = $htmltext;
	}	

	# $o tells us that we don't wanna look at the consistent families lateron
	# so we will filter all out that have only one set
	if ( ( scalar( keys %sets ) == 1 ) && defined( $o ) && ( $o == 1 ) ) {

	  foreach my $kk ( keys %sets ) {	    
	    # count all members of that one set to overallconsistency
	    $overallconsistency += $sets{ $kk };
	  }
	  # from here on ignore that set
	  next;
	}
	
	# $k tells us if we try to collapse the sets using SameFunc
	if ( defined( $k ) && ( $k == 1 ) ) {
	    
	    # hashref $newsets will include the collapsed sets computed by collapse_sets
	    my $newsets = &collapse_sets( \%sets );
	    
	    # backup the old sets
	    my %oldsets = %sets;
	    
	    # $newsets will now be the sets we're working with
	    %sets = %$newsets;
	    
	    # now again the test if the family is now consistent
	    if ( ( scalar( keys %sets ) == 1 ) && defined( $o ) && ( $o == 1 ) ) {
		
		foreach my $kk ( keys %sets ) {
		    $overallconsistency += $sets{ $kk };
		}
		next;
	    }
	}

	if ( $t ) {
	    # now print the results to STDOUT
	    print $tf."\t";
	    print scalar( @{ $FamsTOPEGs->{ $tf } } )."\t";
	    print $FamFunction->{ $tf }->{ 'function' }."\t";
	    print "\n----------";
	}
	$filecounter += 1;
	# same block in HTML
	# first have a look if we have to create a new file
	if ( ( $filecounter % $skip  == 0 ) && ( $filecounter != 0 ) ) {
	    
	    $html_old =~ /(.*)(Comparison.*)\.html/;
	    my $workingdir = $1;
	    my $thisfile = $2;
	    $thisfile .= $filecounter;
	    $thisfile .= ".html";
	    
	    $html = $thisfile;
	    my $htmlprint = $workingdir.'/'.$thisfile;
	    
	    print HTML "<P><A HREF=\"$html\">NEXT $skip<A></P>\n";
	    print HTML "</BODY>\n</HTML>";
	    close HTML;
	    open ( HTML, ">$htmlprint" );
	    
	    print HTML $hdr;
	}
	    
	print HTML "<B>".$tf."</B>, -- Function:<B>";
	if ( $FamFunction->{ $tf }->{ 'function' } eq '' ) {
	    print HTML '&nbsp;';
	}
	else {
	    print HTML $FamFunction->{ $tf }->{ 'function' };
	}
	print HTML "</B>, -- Number of hits: <B>".scalar( @{ $FamsTOPEGs->{ $tf } } )."</B>\n";
	
	my @numbers = ();
	my $accuracy_value = 0;
	
	print HTML "<P style=\"margin-bottom:5%\">";
	print HTML "<TABLE border=1>\n";
	print HTML "<TR><TD><B>Number of proteins</B></TD><TD><B>Accurate</B></TD><TD><B>Annotation</B></TD></TR>\n";
	
	foreach my $set ( keys %sets ) {
	    
	    # print all the sets
	    if ( $t ) {
		print "\n". $sets{ $set } . "\t". $set;
	    }

	    print HTML "<TR><TD>".$sets{ $set };
	    if ( $set eq '' ) {
		print HTML "</TD><TD>-</TD><TD>&nbsp;</TD></TR>\n";
	    }
	    else {
		# look if the function is accurate
		my ( $wannaknow, $throwaway ) = &SameFunc::same_func_why( $FamFunction->{ $tf }->{ 'function' }, $set, $d );
		if ( $wannaknow ) {
		    print HTML "</TD><TD>*</TD><TD>$set</TD></TR>\n";
		}
		else {
		    print HTML "</TD><TD>-</TD><TD>$set</TD></TR>\n";
		}
	    }
	    if ( $sets{ $set } > 1 ) {
		push @numbers, $sets{ $set };
	    }
	    
	    # compute accuracy value
	    my ( $wannaknow, $throwhaway ) = &SameFunc::same_func_why( $FamFunction->{ $tf }->{ 'function' }, $set, $d );
	    if ( $z && $wannaknow ) {
		$accuracy_value += ( $sets{ $set } / scalar( @{ $FamsTOPEGs->{ $tf } } ) );
	    }
	}
	print HTML "</TABLE>\n\n";
	print HTML "<INPUT TYPE=BUTTON VALUE='Show details' ONCLICK='switch_element(\"".$tf;
	print HTML "\");' id='".$tf."\_button'><BR/>\n";
	print HTML "<SPAN ID='".$tf."' CLASS=hideme>";
	print HTML $HTMLTEXTFORFAMILY{ $tf };
	print HTML "</SPAN></P>\n";
	
	# look if we gotta print the consistency value
	if ( $y ) {
	    if ( $t ) {
		print "\n----------\n";
	    }
	    
	    my $consistency_value = 0;
	    ( $consistency_value, $overallconsistency ) = &compute_consistency_value( $overallconsistency, scalar( @{ $FamsTOPEGs->{ $tf } } ), \@numbers );
	    
	    if ( $t ) {
		print $consistency_value."\n";
	    }
	    # look if we gotta print the accuracy value
	    if ( $z && $t ) {
		print $accuracy_value."\n";
	    }
	    
	}
	if ( $t ) {
	    print "\n----------\n\n\n";
	}
	
	$counter++;
	
    }
    
    if ( defined( $excel_link ) ) {
	close EXCEL;
    }

    close HTML;
    
    # print file tail
    
    if ( $defcounter != 0 ) {
	$overallconsistency = $overallconsistency / $defcounter;
	$overallaccuracy = $overallaccuracy / $defcounter;
    }
    else {
	return ( 0, 0, 0 );
    }
    
    if ( $t ) {
	print "Families:       $counter\n";
	print "DEFINED CDSs:   $defcounter\n";
	print "UNDEFINED CDSs: $undefcounter\n";
	print "CONSISTENCY:    $overallconsistency\n";
	print "ACCURACY:       $overallaccuracy\n";
    }
    print STDERR $defcounter. " DEFCOUNTER\n";
    return ( $counter, $defcounter, $overallconsistency );
}

  
sub print_html_hdr {

    my $txt = "<HTML>\n<BODY>\n";

    # TOBI makes me create a function.... I don't like it but he does...
    # Hopefully I understand it...
    $txt .= "<STYLE>.hideme {display: none;} .showme {} td {border: 1px solid black; padding: 3px; font-size: 10pt} table {border-spacing: 0px; } body {font-family: Helvetica; font-size: 10pt;}</STYLE>\n";
    $txt .= qq~<SCRIPT>
	function switch_element (id) {
	    if (document.getElementById(id + '_button').value=='Show details') {
		document.getElementById(id + '_button').value='Hide'; 
		document.getElementById(id).className='showme';
	    } 
	    else {
		document.getElementById(id + '_button').value='Show details'; 
		document.getElementById(id).className='hideme';
	    }
	}
    </SCRIPT>~;
    
    return $txt;

}


#############################
#                           #
# Get the Consistency value #
#                           #
#############################
sub compute_consistency_value {
    
    my ( $overallconsistency, $all_set, $numbs ) = @_;

    my $consistency_value = 0;
    my $wasin = 0;    

    foreach my $num ( @$numbs ) {
	my $thisvalue = ( $num / $all_set ) * ( ( $num - 1 ) / ( $all_set - 1 ) );
	$consistency_value += $thisvalue;
	$wasin = 1;
    }
    if ( !$wasin ) {
	$overallconsistency += 1;
    }
    else {
	$overallconsistency += ( $consistency_value * $all_set );
    }
    
    return( $consistency_value, $overallconsistency );
    
}

##################################
#                                #
# Collapse sets using SameFunc   #
#                                #
# This is not yet perfect, as    #
# there is no transitive closure #
#                                #
##################################
sub collapse_sets {
    
    my ( $old_sets ) = @_;
    
    # create an empty hash that will include the collapsed set at the end
    my $new_sets = {};
    
    # create an array of the old keys
    my @old_sets_array = keys %$old_sets;
    
    # go through that array
    for ( my $i = 0; $i < scalar( @old_sets_array ); $i++ ) {
	
	# get the first entry of that array
	my $name1 = @old_sets_array[ $i ];

	my $found = 0;

	# go through new sets
	for ( my $j = 0; $j < scalar( keys %$new_sets ); $j++ ) {
	    
	    # get the entry
	    my @news = keys %$new_sets;
	    my $name2 = @news[ $j ];
	    
	    # see if annotations are the same
	    my ( $same, $throwaway ) = &SameFunc::same_func_why( $name1, $name2, $d );

	    if ( $same ) {
		$found = 1;
		
		# create a collapsed name
		my $newname = "$name2 ### $name1";
		    
		    # add the numbers
		    $new_sets->{ $newname } = $new_sets->{ $name2 } + $old_sets->{ $name1 };

		# delete the old entry
		delete $new_sets->{ $name2 };
		last;
	    }
	}
	# if not found put name just in the new_sets
	if ( !$found ) {
	    $new_sets->{ $name1 } = $old_sets->{ $name1 };
	}
    }
  
    return $new_sets;

}

sub getpeg {

    my ( $oldpeg, $idhash ) = @_;

    my $newpeg;

    if ( $oldpeg =~ /^fig/ ) {
	$newpeg = $oldpeg;
    }
    else {
	$newpeg = $idhash->{ $oldpeg };
    }

    return $newpeg;

}

sub build_pathema_hash {

  my $pmwdir = "/vol/brc-quality-control/output-stage/PATHEMAMAPWEB";

  opendir( DIR, $pmwdir ) or die "cannot open $pmwdir\n";
  my $pmwhash;

  my @files = readdir( DIR );

  foreach my $f ( @files ) {
    my $genomedb;
    if ( $f =~ /^b\_.*/ ) {
      $genomedb = "Burkholderia";
      if ( $f =~ /^b\_anthracis.*/ || $f =~ /^b\_cereus.*/ || $f =~ /^b\_thuringiensis.*/ || $f =~ /^b\_subtilis.*/ ) {
	$genomedb = "Bacillus";
      }
    }
    elsif ( $f =~ /^c\_.*/ ) {
      $genomedb = "Clostridium";
    }
    elsif ( $f =~ /^e\_.*/ ) {
      $genomedb = "Entamoeba";
    }

    open ( FILE, $pmwdir."/".$f ) or die "cannot open file $pmwdir"."/".$f;
    while ( <FILE> ) {
      chomp;
      my ( $id, $webid ) = split( "\t", $_ );
      $pmwhash->{ $id }->{ 'webname' } = $webid;
      $pmwhash->{ $id }->{ 'orgdir' } = $genomedb;
 #     print STDERR $id ." and ". $webid." and ".$genomedb."\n";
    }
    close FILE;
  }
  return $pmwhash;
}

sub build_hash {
  
  my ( $short ) = @_;
  #print STDERR $short." SHORT\n";
  my $hash;
  
  my $correspondence_file = "/vol/brc-quality-control/output-stage/id-correspondence";
  
  open ( CORR, $correspondence_file );
  
  while ( <CORR> ) {
    my $line = $_;
    #	  print STDERR $line."\n";
    chomp $line;
    if ( $line =~ /$short/ ) {
      #	  print STDERR $line."\n";
      my @ids = split( /\t/, $line );
      
      my $figid = '';
      
      my @keys;
      
      foreach my $id ( @ids ) {
	#	      print STDERR $id."\n";
	
	if ( $id =~ /$short/ ) {
	  push @keys, $id;
	}
	elsif ( ( $id =~ /fig/ ) && ( $figid eq '' ) ) {
	  $figid = $id;
	}
      }    
      
      foreach my $i ( @keys ) {
	$hash->{ $i } = $figid;
      }	 
    }
  }
  close CORR;
  #exit(0);
  return $hash;
}

############################################################
#                                                          #
# Call this method if some of the families should be       #
# ignored in the analysis. It reads those from a file into #
# a hashref and returns the hashref.                       #
#                                                          #
############################################################
sub read_filterout {

    my ( $s, $file ) = @_;

    my %filterout;

    open ( FAMILIES, $file );
    while ( <FAMILIES> ) {

	if ( $s eq 't' ) {

	    if ( $_ =~ /(TIGR\d+)/ ) {

		$filterout{ $1 } = 1;

	    }

	}
	elsif ( $s eq 'f' ) {

	    if ( $_ =~ /(FIG\d+)/ ) {

		$FILTEROUT{ $1 } = 1;

	    }
	}
    }
    close FAMILIES;

    return \$filterout;

}

#############################################
#                                           #
# Reads the F2-func file and returns a hash #
#                                           #
# F2-func looks like this:                  #
# Family_ID \t Family_function              #
#                                           #
#############################################
sub read_famfunction {

    my ( $file, $s ) = @_;

    my %famfunction;
    
    open ( FamFunction, "$file" );
    
    while ( <FamFunction> ) {
	if ( $s eq 't' ) {
	    # if we use TIGRFAMs => $opt_s = 't'
	    
	    # In the TIGR family file a line looks like this:
	    # TIGRfam\t(Abbreviation:Function)
	    my ( $tigrfam, $short, $function ) = ( $_ =~ /(TIGR\d+)\t(.*)\:(.*)/ );
	    
	    $famfunction{ $tigrfam }->{ 'short' } = $short;
	    $famfunction{ $tigrfam }->{ 'function' } = $function;
	    
	}
	elsif ( $s eq 'f' ) {
	    # if we use FIGFAMs => $opt_s = 'f'
	    
	    # In the FIG family file a line looks like this:
	    # FIGfam\tFunction
	    my ( $figfam, $function ) = ( $_ =~ /(FIG\d+)\t(.*)/ );
	    
	    $famfunction{ $figfam }->{ 'function' } = $function;
	    
	}
	elsif ( $s eq 'p' ) {
	    # if we use PIRFAMs => $opt_s = 'p'
	    
	    # In the PIR family file a line looks like this:
	    # PIRfam\tFunction
	    my ( $pirfam, $function ) = ( $_ =~ /(PIRSF\d+)\t(.*)/ );
	    
	    $famfunction{ $pirfam }->{ 'function' } = $function;
	    
	}
    }	
    close FamFunction;

    return \%famfunction;
}

####################################################
#                                                  #
# Reads the peg - pegfunction relation into a hash #
#                                                  #
# The file has the following format:               #
# CDS_id \t Function                               #
#                                                  #
####################################################
sub read_pegfunction {

    my ( $file ) = @_;

    my %pegfunction;

    open ( PegFunction, "$file" );

    while ( <PegFunction> ) {
	
	my ( $peg, $function ) = ( $_ =~ /(.+)\t(.*)/ );

#	print STDERR $peg." PEG!\n";

	$pegfunction{ $peg } = $function;

    }

    close PegFunction;
    open ( PegFunction, "$file" );

    my $abr = 'bloedsinn';

    while ( <PegFunction> ) {

	my ( $peg, $function ) = ( $_ =~ /(.+)\t(.*)/ );

	if ( $peg =~ /eric/ ) {
	    $abr = 'eric';
	}
	elsif ( $peg =~ /fig/ ) {
	    $abr = 'fig';
	}
	elsif ( $peg =~ /patric/ ) {
	    $abr = 'patric';
	}
	elsif ( $peg =~ /ref/ ) {
	    $abr = 'ref';
	}
	elsif ( $peg =~ /tigr/ ) {
	    $abr = 'tigr';
	}
	elsif ( $peg =~ /nmpdr/ ) {
	    $abr = 'nmpdr';
	}
	elsif ( $peg =~ /uni/ ) {
	    $abr = 'uni';
	}
	elsif ( $peg =~ /sp/ ) {
	    $abr = 'sp';
	}
	elsif ( $peg =~ /pathema/ ) {
	    $abr = 'pathema';
	}
	last;
    }

    close PegFunction;
    return ( \%pegfunction, $abr );

}

############################################
#                                          #
# Read the F2-id file into a hash          #
#                                          #
# The F2-id file has the following format: #
# Family_id \t CDS_id                      #
#                                          #
############################################

sub read_familyids {

    my ( $s, $file ) = @_;
#    print STDERR $file ." FILE\n";
    my %famstopegs;

    open ( IDPEG, "$file" );

    # to avoid that some pegs are double, i will need a little hash:
    my %avoiddouble;

    while ( <IDPEG> ) {

        if ( $s eq 't' ) {
	
	    my ( $tigrfam, $peg ) = ( $_ =~ /(TIGR\d+)\t(.*)/ );
	    if ( $peg =~ /(apidb\|)cds\_(.*)\-\d$/ ) {
	      $peg = $1.$2;
	    }
	    $avoiddouble{ $tigrfam }->{ $peg } = 1;
	
	}
	elsif ( $s eq 'f' ) {
	
	    my ( $figfam, $peg ) = ( $_ =~ /(FIG\d+)\t(.*)/ );
	    if ( $peg =~ /(apidb\|)cds\_(.*)\-\d$/ ) {
	      $peg = $1.$2;
	    }
	    $avoiddouble{ $figfam }->{ $peg } = 1;
	  
	}
	elsif ( $s eq 'p' ) {

	    my ( $pirfam, $peg ) = ( $_ =~ /(PIRSF\d+)\t(.*)/ );
	    if ( $peg =~ /(apidb\|)cds\_(.*)\-\d$/ ) {
	      $peg = $1.$2;
	    }
	    $avoiddouble{ $pirfam }->{ $peg } = 1;

	}
    }
 
    # Now I will need to fill the hash famstopegs
    foreach my $fam ( keys %avoiddouble ) {

        my @tmparray = keys %{ $avoiddouble{ $fam } };
	$famstopegs{ $fam } = \@tmparray;
	    
    }
    close IDPEG;

    return \%famstopegs;

}

sub create_proteintable_html {

    my ( $pegs, $pegfunction, $famfunction, $idhash, $seedurl, $d, $pathemahash ) = @_;
    
    my $htmltext = '';
    $htmltext .= "<TABLE border=1>\n";
    $htmltext .= "<TR><TD>ID</TD><TD>Function</TD><TD>Protein in SEED</TD></TR>\n";
    
    # go through pegs of a tigrfam
    foreach my $peg ( sort @$pegs ) {
	
	# if the peg can't be found in PegFunction it's undefined
	if ( !defined( $pegfunction->{ $peg } ) ) {
	    next;
	}
	
	my $pl = "<TR><TD>";

	my $peglink = &getpeglink( $peg, $pathemahash );
	if ( $peglink == -1 ) {
	    $pl .= $peg."</TD>";
	}
	else {
	    $pl .= "<A HREF=\"".$peglink."\" target=\_blank >".$peg."</A></TD>";
	}

	$htmltext .= $pl;

	if ( $pegfunction->{ $peg } ne '' ) {
	    $htmltext .= "<TD>".$pegfunction->{ $peg }."</TD>";
	}
	else {
	    $htmltext .= "<TD>&nbsp;</TD>";
	}

	my $figpeg = &getpeg( $peg, $idhash );
	
	if ( $figpeg eq '' ) {
	    if ( $peg =~ /^nmpdr.*(fig.*)/ ) {
		my $ffpp = $1;
		$htmltext .= "<TD><A HREF=\"".$seedurl;
		$htmltext .= $ffpp."\" target=\_blank >".$ffpp."</A></TD>";
	    }
	    else {   
		$htmltext .= "<TD>-<\TD>";
	    }
	}
	else {
	    $htmltext .= "<TD><A HREF=\"".$seedurl;
	    $htmltext .= $figpeg."\" target=\_blank >".$figpeg."</A></TD>";
	}
	$htmltext .= "</TR>\n";
    }
    
    $htmltext .= "</TABLE>";
    
    return $htmltext;
    
}

sub getpeglink {
    my ( $peg, $pathemahash ) = @_;

    if ( $peg =~ /nmpdr\|(.*)/ ) {
	my $link = $1;
	if ( !defined( $link ) ) {
	    return -1;
	}
	else {
	    $link = "http://www.nmpdr.org/linkin.cgi?id=fig|".$link;
	    return $link;
	}
    }
    elsif ( $peg =~ /pathema/ ) {
      my $link = &get_rightname_pathema( $peg, $pathemahash );
      return $link;
    }
    elsif ( $peg =~ /eric\|(.*)/ ) {
	my $link = $1;
	if ( !defined( $link ) ) {
	    return -1;
	}
	else {
	    $link = "https://asap.ahabs.wisc.edu/asap/feature_info.php?FeatureID=".$link;
	    return $link;
	}
    }
    elsif ( $peg =~ /vectorbase\|(.*)/ ) {
	my $link = $1;
	if ( !defined( $link ) ) {
	    return -1;
	}
	else {
	    $link = "http://agambiae.vectorbase.org/Search/Keyword/?term=".$link;
	    return $link;
	}
    }
    elsif ( $peg =~ /patric\|cds\.0*(\d+)\.(\d+)/ ) {
	my $a = $1;
	my $b = $2;
	if ( defined( $a && defined( $b ) ) ) {
	    $link = "http://patric.vbi.vt.edu/gene/overview.php?fid=".$b;
	}
	return $link
    }

    return -1;
}

sub getpeglink_OLDVERSION {
    my ( $peg ) = @_;

    if ( $peg =~ /nmpdr\|(.*)/ ) {
	my $link = $1;
	if ( !defined( $link ) ) {
	    return -1;
	}
	else {
	    $link = "http://www.nmpdr.org/linkin.cgi?id=".$link;
	    return $link;
	}
    }
    elsif ( $peg =~ /pathema/ ) {
	my $link = &get_rightname_pathema( $peg );
	if ( $link == -1 ) {
	    return -1;
	}
	else {
	    $link = "http://pathema.tigr.org/tigr-scripts/pathema/shared/GenePage.cgi?locus=".$link;
	    return $link;
	}
    }
    elsif ( $peg =~ /eric\|(.*)/ ) {
	my $link = $1;
	if ( !defined( $link ) ) {
	    return -1;
	}
	else {
	    $link = "https://asap.ahabs.wisc.edu/asap/feature_info.php?FeatureID=".$link;
	    return $link;
	}
    }
    elsif ( $peg =~ /patric\|cds\.0*(\d+)\.(\d+)/ ) {
	my $a = $1;
	my $b = $2;
	if ( defined( $a && defined( $b ) ) ) {
	    $link = "https://patric.vbi.vt.edu/software/curationTool/gep/pgiCuration.php?sid=".$a."&fid=".$b;
	}
	return $link
    }

    return -1;
}

sub get_rightname_pathema {
  my ( $oldname, $pathemahash ) = @_;

  my $newname = $pathemahash->{ $oldname }->{ 'webname' };
  my $genomedb = $pathemahash->{ $oldname }->{ 'orgdir' };

  if ( defined( $genomedb ) && defined( $newname ) ) {
    return "http://pathema.jcvi.org/tigr-scripts/".$genomedb."/shared/GenePage.cgi?locus=".$newname;
  }
  else {
    return $oldname;
  }
}

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3