Re: Clustering with Perl

This code will cluster your "genes".. I do not know how far it goes to allow you to solve the second part of your problem.

#!/usr/bin/perl

use warnings;
use strict;
my %adjacent;
while (<DATA>) {
    my @component = split /\,/, $_, 3;
    my $parent;
    if ( defined($adjacent{$component[0]})) {
        $adjacent{$component[0]}{$component[1]} = $component[2];
    }
    elsif ( defined($adjacent{$component[1]})) {
        $adjacent{$component[1]}{$component[0]} = $component[2];
    }
    elsif ( $parent = has_parent($component[0]) ) {
    $adjacent{$parent}{$component[1]} = $component[2];
    }
    elsif ( $parent = has_parent($component[1]) ) {
    $adjacent{$parent}{$component[0]} = $component[2];
    }
    else {
        $adjacent{$component[0]}{$component[1]} = $component[2];
    }
}
print "\n\n*----------------------------------------------*\n";
for my $inner ( sort keys %adjacent ) {
    print "$inner ";
    for my $outer ( sort keys %{$adjacent{$inner}} ) {
        print ", $outer";
    }
    print "\n";
}

sub has_parent {
    my $candidate = shift;
    for my $inner ( sort keys %adjacent ) {
    for my $outer ( sort keys %{$adjacent{$inner}} ) {
        if ( $candidate eq $outer ) {
        return $inner;
        }
    }
    }
    return 0;    
}


__DATA__
Gene1,Gene2,spc1,spc2 
Gene3,Gene1,spc1,spc2,spc4 
Gene4,Gene1,spc1,spc2,spc5,spc3,spc1 
Gene2,Gene3,spc1,spc2 
Gene2,Gene4,spc2,spc3 
Gene3,Gene4,spc1,spc2 
GeneA,GeneB,spc4,spc5 
GeneB,GeneC,spc1,spc2 
GeneC,GeneD,spc1,spc2 
GeneD,GeneE,spc4,spc2 
GeneE,GeneF,spc3,spc1 
GeneX,GeneY,spc6,spc8 
GeneX,GeneP,spc6,spc7
[download]

And the results are:

C:\Code>perl adjacent.pl

*----------------------------------------------*
Gene1 , Gene2, Gene3, Gene4
GeneA , GeneB, GeneC, GeneD, GeneE, GeneF
GeneX , GeneP, GeneY
[download]

Update: newer code solves it completely.

#!/usr/bin/perl

use warnings;
use strict;
#
# %adjacent  - each key contains a cluster identified by the key (root
+).
# %sequences - contains sequences of "spcs" for each cluster.
#
my %adjacent;
my %sequences;
while (<DATA>) {
    chomp;
    my @component = split /\,/, $_, 3;
    my $parent;
    $component[2] =~ s/\s+$//;
    if ( $parent = has_root($component[0]) ) {
    push @{$adjacent{$parent}}, $component[1] 
        unless ( has_root($component[1]));
    push @{$sequences{$parent}}, $component[2];
    }
    elsif ( $parent = has_root($component[1]) ) {
    push @{$adjacent{$parent}}, $component[0]
        unless ( has_root($component[0]));
    push @{$sequences{$parent}}, $component[2];
    }
    else {
        push @{$adjacent{$component[0]}}, $component[1];
    push @{$sequences{$component[0]}}, $component[2];
    }
}
print "*----------------------------------------------*\n";
for my $inner ( sort keys %adjacent ) {
    print "$inner";
    for my $outer ( sort @{$adjacent{$inner}} ) {
        print ",$outer";
    }
    for (@{$sequences{$inner}}) {
        print ",$_";
    }        
    print "\n";
}
sub has_root {
    my $candidate = shift;
    return 0 if ( keys %adjacent < 1);
    for my $inner ( sort keys %adjacent ) {
    if ( $candidate eq $inner ) {
        return $inner;
    }
    for my $outer ( sort @{$adjacent{$inner}} ) {
        if ( $candidate eq $outer ) {
        return $inner;
        }
    }
    }
    return 0;    
}


__DATA__
Gene1,Gene2,spc1,spc2 
Gene3,Gene1,spc1,spc2,spc4 
Gene4,Gene1,spc1,spc2,spc5,spc3,spc1 
Gene2,Gene3,spc1,spc2 
Gene2,Gene4,spc2,spc3 
Gene3,Gene4,spc1,spc2 
GeneA,GeneB,spc4,spc5 
GeneB,GeneC,spc1,spc2 
GeneC,GeneD,spc1,spc2 
GeneD,GeneE,spc4,spc2 
GeneE,GeneF,spc3,spc1 
GeneX,GeneY,spc6,spc8 
GeneX,GeneP,spc6,spc7
[download]

Comment on Re: Clustering with Perl Select or Download Code

Replies are listed 'Best First'.
Re^2: Clustering with Perl by nerve (Initiate) on Jun 25, 2009 at 00:56 UTC
The gene number can basically vary. you can have <2 genes Hi there, Your code worked like a charm although it has a bug or a error on my side providing incomplete details. My sample input was Gene1,Gene2,spc1,spc2 Gene3,Gene1,spc1,spc2,spc4 Gene4,Gene1,spc1,spc2,spc5,spc3,spc1 etc And I got the correct results. But the sample can contains entries like the bellow GeneX,GeneY,GeneP,spc1,spc2 GeneY,spc3,spc4 The desired result would be GeneX,GeneY,GeneP,spc1,spc2,spc3,spc4 But the results which the script gives is GeneX,GeneY,spc3,GeneP,spc1,spc2,spc4 ************************************************************* Also how can i modify the cureent code to give me aoutput like this Sample input GeneX,GeneY,GeneP,spc1,spc2 GeneY,spc3,spc4 GeneZ,spc3,spc4 Desired Result GeneX,GeneY,GeneP,GeneZ,spc1=1,spc2=1,spc3=2,spc4=2 I want to count the number of \/ "spc" for a given "spc" /\ so that i can later confirm the output. because I have a 25 mb txt file to process which will probably take hour or more.	[reply]
Re^3: Clustering with Perl by dwm042 (Priest) on Jun 26, 2009 at 17:24 UTC
nerve, Looking at the things you want done, I don't see how code can tell that `GeneX,GeneY,GeneP,spc1,spc2 GeneY,spc3,spc4 GeneZ,spc3,spc4` [download] Should lead to: `Desired Result GeneX,GeneY,GeneP,GeneZ,spc1=1,spc2=1,spc3=2,spc4=2` [download] What in the data set "says" that GeneZ is to be clustered with X, Y, and P? Nothing that I can determine. The counts (e.g. spc1=1, etc) would be easy to do and the code I presented creates a stack of spc results. Just pop results off the stack, and count instances. David.	[reply] [d/l] [select]
Re^3: Clustering with Perl by dwm042 (Priest) on Jun 26, 2009 at 18:21 UTC
This is as close as I can come, given that the description of how to process data is inconsistent. The trick here is to partition the split data set into an array of genes and an array of spcs and work with that. I'm sure others here can make this prettier code than I. If you want it spaced nicely, please run a copy of perltidy on this code. #!/usr/bin/perl use warnings; use strict; # # %adjacent - is a hash of arrays. # each key contains a cluster identified by the key (root +). # %sequences - is a hash of hashes. # The first key is identical to a key (root) in %adjacent +. # The second key ids each "spcs" in the cluster. # The value is the count of "spc". # my %adjacent; my %sequences; while (<DATA>) { chomp; next unless $_ =~ /\w+/; my @component = split /\,/, $_; my @genes; my @spcs; for my $element (@component) { $element =~ s/\s+$//; if ( $element =~ /^Gene/i ) { push @genes, $element; } else { push @spcs, $element; } } if ( my $parent = rooted( \@genes ) ) { for my $gene (@genes) { push @{$adjacent{$parent}}, $gene unless ( has_root($gene)); } for my $species (@spcs) { $sequences{$parent}{$species}++; } } else { my $root = shift @genes; @{$adjacent{$root}} = (); for my $gene ( @genes ) { push @{$adjacent{$root}}, $gene unless ( has_root($gene)); } for my $species (@spcs) { $sequences{$parent}{$species}++; } } } print "----------------------------------------------\n"; for my $inner ( sort keys %adjacent ) { print "$inner"; for my $outer ( sort @{$adjacent{$inner}} ) { print ",$outer"; } for (sort keys %{$sequences{$inner}}) { printf ",%s=%d", $_, $sequences{$inner}{$_}; } print "\n"; } sub has_root { my $candidate = shift; return 0 if ( keys %adjacent < 1); for my $inner ( sort keys %adjacent ) { if ( $candidate eq $inner ) { return $inner; } for my $outer ( sort @{$adjacent{$inner}} ) { if ( $candidate eq $outer ) { return $inner; } } } return 0; } sub rooted { my $aref = shift; for (@$aref) { my $parent = has_root( $_ ); return $parent if $parent; } return 0; } __DATA__ Gene1,Gene2,spc1,spc2 Gene3,Gene1,spc1,spc2,spc4 Gene4,Gene1,spc1,spc2,spc5,spc3,spc1 Gene2,Gene3,spc1,spc2 Gene2,Gene4,spc2,spc3 Gene3,Gene4,spc1,spc2 GeneA,GeneB,spc4,spc5 GeneB,GeneC,spc1,spc2 GeneC,GeneD,spc1,spc2 GeneD,GeneE,spc4,spc2 GeneE,GeneF,spc3,spc1 GeneX,GeneY,spc6,spc8 GeneX,GeneY,GeneP,spc1,spc2 GeneY,spc3,spc4 [download] With the results: `C:\Code>perl adjacent.pl ---------------------------------------------- Gene1,Gene2,Gene3,Gene4,spc1=5,spc2=5,spc3=2,spc4=1,spc5=1 GeneA,GeneB,GeneC,GeneD,GeneE,GeneF,spc1=3,spc2=3,spc3=1,spc4=1 GeneX,GeneP,GeneY,spc1=1,spc2=1,spc3=1,spc4=1` [download]	[reply] [d/l] [select]