File Coverage

blib/lib/Microarray/ExprSet.pm

Criterion	Covered	Total	%
statement	112	121	92.5
branch	29	38	76.3
condition	6	11	54.5
subroutine	16	16	100.0
pod	13	13	100.0
total	176	199	88.4

package Microarray::ExprSet;

# Simple description of microarray data
# contains three elements
# data matrix
# feature (gene) names array
# sample names array

use List::Vectorize;
use Carp;
use strict;

our $VERSION = "0.11";

1;


sub new {

    my $invocant = shift;
    my $class = ref($invocant) || $invocant;
    my $self = { feature => undef,
                 phenotype => undef,
                 matrix => undef,
                 error => undef,};
    bless($self, $class);
    return $self;

}


# probe name
sub feature {

    my $self = shift;

    return $self->{feature};

}

sub set_feature {

    my $self = shift;

    List::Vectorize::check_prototype(@_, '\@');

    my $feature = shift;

    $self->{feature} = $feature;

    return $self;

}

# sample name
sub phenotype {

    my $self = shift;

    return $self->{phenotype};

}

sub set_phenotype {

    my $self = shift;

    List::Vectorize::check_prototype(@_, '\@');

    my $phenotype = shift;

    $self->{phenotype} = $phenotype;

    return $self;

}

sub set_matrix {

    my $self = shift;

    List::Vectorize::check_prototype(@_, '\@');

    my $matrix = shift;

    # check whether it is a valid matrix
    my ($nr, $nc) = dim($matrix);
    if(!defined($nr) or !defined($nc)) {
        croak "ERROR: Not a valid matrix";
    }

    $self->{matrix} = $matrix;

    return $self;

}

sub matrix {

    my $self = shift;

    return $self->{matrix};

}

sub is_valid {

    my $self = shift;
    $self->{error} = undef;

    if(defined($self->matrix)) {

        my ($nr, $nc) = dim($self->matrix);

        if(!defined($nr) or !defined($nc)) {
            $self->{error} = "Not a matrix";
            return 0;
        }

        if(defined($self->feature)) {
            if(len($self->feature) != $nr) {
                $self->{error} = "Length of feature names is not identical to the number of matrix rows";
                return 0;
            }
        }

        if(defined($self->phenotype)) {
            if(len($self->phenotype) != $nc) {
                $self->{error} = "Length of phenotype names is not identical to the number of matrix columns";
                return 0;
            }
        }
    }
    else {
        $self->{error} = "Expression matrix is not defined";
        return 0;
    }

    return 1;
}


sub remove_empty_features {

    my $self = shift;

    my $old_feature = $self->feature;
    my $old_matrix = $self->matrix;

    if(is_empty($old_feature)) {
        carp "WARN: Feature names are empty. ";
    }
    elsif(! $self->is_valid) {
        croak $self->{error};
    }

    my $new_feature;
    my $new_matrix;

    for(my $i = 0; $i < len($old_feature); $i ++) {

        if($old_feature->[$i] !~ /^\s*$/) {
            push(@$new_feature, $old_feature->[$i]);
            push(@$new_matrix, $old_matrix->[$i]);
        }
    }

    $self->set_feature($new_feature);
    $self->set_matrix($new_matrix);
    undef($old_feature);
    undef($old_matrix);

    return $self;
}

sub n_feature {

    my $self = shift;

    return len($self->feature);

}

sub n_phenotype {

    my $self = shift;

    return len($self->phenotype);

}

# using mean or median
sub unique_features {

    my $self = shift;
    my $method = shift || "mean";

    my $fun;
    if($method eq "mean") {
        $fun = \&mean;
    }
    elsif($method eq "median") {
        $fun = \&median;
    }
    else {
        $fun = \&mean;
    }

    my $fh;
    my $feature = $self->feature;

    if(is_empty($feature)) {
        carp "WARN: Feature names are empty. ";
    }
    elsif(! $self->is_valid) {
        croak $self->{error};
    }

    for(my $i = 0; $i < len($feature); $i ++) {
        if($fh->{$feature->[$i]}) {
            push(@{$fh->{$feature->[$i]}}, $i);
        }
        else {
            $fh->{$feature->[$i]}->[0] = $i;
        }
    }

    my $new_feature;
    my $new_matrix;
    my $matrix = $self->matrix;
    foreach my $f (keys %$fh) {

        my $index = $fh->{$f};
        push(@$new_feature, $f);

        if(len($index) == 1) {
            push(@$new_matrix, $matrix->[$index->[0]]);
        }
        else {
            my $new_array;
            for(my $i = 0; $i < len($matrix->[0]); $i ++) {
                my $tmp_array;
                for(my $j = 0; $j < len($index); $j ++) {

                    push(@$tmp_array, $matrix->[$index->[$j]]->[$i]);

                }
                push(@$new_array, &$fun($tmp_array));
            }
            push(@$new_matrix, $new_array);
        }
    }

    $self->set_feature($new_feature);
    $self->set_matrix($new_matrix);
    undef($feature);
    undef($matrix);

    return $self;
}

sub save {

    my $self = shift;

    List::Vectorize::check_prototype(@_, '$');

    my $file = shift;

    if(is_empty($self->feature)) {
        croak "ERROR: Feature names are required. ";
    } elsif(is_empty($self->phenotype)) {
        croak "ERROR: Phenotype names are required. ";
    } elsif(! $self->is_valid) {
        croak "ERROR: not a valid ".__PACKAGE__." object";
    }

    write_table($self->matrix, "file" => $file, "row.names" => $self->feature, "col.names" => $self->phenotype);

    return 1;
}


__END__