view release on metacpan or  search on metacpan

perl/Record.pm  view on Meta::CPAN

package Algorithm::Cluster::Record;
use strict;

use Algorithm::Cluster;

sub new {
    my $class = shift;
    my $self = {};
    $self->{data} = undef;
    $self->{mask} = undef;
    $self->{geneid} = undef;
    $self->{genename} = undef;
    $self->{gweight} = undef;
    $self->{gorder} = undef;
    $self->{expid} = undef;
    $self->{eweight} = undef;
    $self->{eorder} = undef;
    $self->{uniqid} = undef;
    bless($self, $class);
    return $self;
}

sub read {
    my $self = shift;
    my $handle = shift;
    my $line = <$handle>;
    chomp($line);
    my @words = split(/\t/, $line);
    my $n = scalar @words;
    $self->{uniqid} = $words[0];
    $self->{expid} = [];
    my %cols = (0 => 'GENEID');
    my $i;
    for ($i = 1; $i < $n; $i++) {
        my $word = $words[$i];
        if ($word eq 'NAME') {
            $cols{$i} = $word;
            $self->{genename} = ();
        }
        elsif ($word eq 'GWEIGHT') {
            $cols{$i} = $word;
            $self->{gweight} = ();
        }
        elsif ($word eq 'GORDER') {
            $cols{$i} = $word;
            $self->{gorder} = ();
        }
        else {
            push(@{$self->{expid}}, $word);
        }
    }
    $self->{geneid} = [];
    $self->{data} = [];
    $self->{mask} = [];
    my $needmask = 0;
    while ($line = <$handle>) {
	my $count = ($line =~ tr/\t//);
        @words = split(/\t/, $line);
	chomp @words;
        scalar @words == $n or die "Line with " . scalar @words . " columns found (expected $n): $!";
        my $start = 0;
        for my $key (keys %cols) {
            if ($key > $start) {
                $start = $key;
            }
        }
        if ($words[0] eq 'EWEIGHT') {
            @{$self->{eweight}} = @words[$start+1..$n-1];
        }
        elsif ($words[0] eq 'EORDER') {
            @{$self->{eorder}} = @words[$start+1..$n-1];
        }
        else {
            my @rowdata = ();
            my @rowmask = ();
            for ($i = 0; $i < $n; $i++) {
                my $word = $words[$i];
                if (defined $cols{$i}) {
                    if ($cols{$i} eq 'GENEID') {
                        push(@{$self->{geneid}}, $word);
                    }
                    elsif ($cols{$i} eq 'NAME') {
                        push(@{$self->{genename}}, $word);
                    }
                    elsif ($cols{$i} eq 'GWEIGHT') {
                        push(@{$self->{gweight}}, $word);
                    }
                    elsif ($cols{$i} eq 'GORDER') {
                        push(@{$self->{gorder}}, $word);
                    }
                }
                else {
                    if ($word) {
                        push(@rowdata, $word);
                        push(@rowmask, 1);
                    }
                    else {
                        push(@rowdata, 0.0);
                        push(@rowmask, 0);
                        $needmask = 1;
                    }
                }
            }
            push(@{$self->{data}}, [@rowdata]);
            push(@{$self->{mask}}, [@rowmask]);
        }
    }
    if (not $needmask) {
        $self->{mask} = undef;
    }
}


sub treecluster {
    my ($self, %args) = @_;
    my %default = (
        transpose  =>     0,
        dist       =>   'e',
        method     =>   'm',
    );
    my %param = (%default, %args);
    $param{data} = $self->{data};
    if (defined $self->{mask}) {
        $param{mask} = $self->{mask};
    }
    if ($param{transpose}==0) {
        $param{weight} = $self->{eweight};
    }
    else {
        $param{weight} = $self->{gweight};
    }