File Coverage

blib/lib/Statistics/Candidates.pm

Criterion	Covered	Total	%
statement	68	69	98.5
branch	10	16	62.5
condition	3	9	33.3
subroutine	10	11	90.9
pod	4	5	80.0
total	95	110	86.3

package Statistics::Candidates;

##---------------------------------------------------------------------------##
##  Author:
##      Hugo WL ter Doest       [e-mail]
##  Description:
##      Object/methods for candidate features
##
##---------------------------------------------------------------------------##
##  Copyright (C) 1998, 1999 Hugo WL ter Doest [e-mail]
##
##  This library is free software; you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation; either version 2 of the License, or
##  (at your option) any later version.
##
##  This library  is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  You should have received a copy of the GNU Library General Public
##  License along with this program; if not, write to the Free Software
##  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
##---------------------------------------------------------------------------##


##---------------------------------------------------------------------------##
##	Globals
##---------------------------------------------------------------------------##
use vars qw($VERSION
	    @ISA
	    @EXPORT
	    $VECTOR_PACKAGE);


##---------------------------------------------------------------------------##
##	Require libraries
##---------------------------------------------------------------------------##
use strict;
use diagnostics -verbose;
use Carp;
use Statistics::SparseVector;
$VECTOR_PACKAGE = "Statistics::SparseVector";
require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
	     );


sub new {
    my($this, $arg) = @_;

    # for calling $self->new($someth):
    my $class = ref($this) || $this;
    my $self = {};
    bless $self, $class;
    if ($arg) {
	$self->read($arg);
    }
    return($self);
}


sub DESTROY {

}


# reads a candidates file
# dies if insufficient events or inconsistent lines
# syntax first line:     ...
# syntax other lines:
sub read {
    my($self, $file) = @_;

    my($features,
       $sum,
       $event,
       $candidate_names);

    # prologue
    open(CANDS, $file) ||
	die "Could not open $file\n";
    print "Opened $file\n";

    # read candidate names, skip comments
    $candidate_names = "";
    do {
	$candidate_names = ;
    } until ($candidate_names !~ /\#.*/);
    chomp $candidate_names;
    $self->{CANDIDATE_NAMES} = [split(/\t/,$candidate_names)];
    $self->{NR_CANDIDATES} = $#{$self->{CANDIDATE_NAMES}} + 1;
    # read the candidate bitvectors
    $self->{NR_CLASSES} = 0;
    while () {
	if (!/\#.*/) {
	    chomp;
	    $features = $_;
	    $self->{CANDIDATES}[$self->{NR_CLASSES}++] =
	      $VECTOR_PACKAGE->new_vec($self->{NR_CANDIDATES}, $features, "binary");
	}
    }

    # epilogue
    close(CANDS);
    # check the candidates for constant functions
    $self->check();
    print "Read $self->{NR_CANDIDATES} candidates for $self->{NR_CLASSES} events; ";
    print "closed $file\n";
}


# check whether for all features f, \sum_x f(x) > 0, and
# \sum_x f(x) != nr_classes
sub check {
    my($self) = @_;

    my($x,
       $f,
       $sum);

    for ($f = 0; $f < $self->{NR_CANDIDATES}; $f++) {
	$sum = 0;
	for ($x = 0; $x < $self->{NR_CLASSES}; $x++) {
	    $sum += $self->{CANDIDATES}[$x]->bit_test($f);
	}
	if (!$sum || ($sum == $self->{NR_CLASSES})) {
	    croak "Candidate ",$f+1, " is constant, remove it\n";
	}
    }
}


# writes remaining candidates to a file
# syntax: same as input candidates file
sub write {
    my($self, $file) = @_;

    my($x,
       $f);

    if (($self->{NR_CANDIDATES} > 0) && ($self->{NR_CLASSES})) {
	open(CANDIDATES,">$file") ||
	    die "Could not open $file\n";
	print "Opened $file\n";

	# write the list of candidate names that were not added
	for ($f = 0; $f < $self->{NR_CANDIDATES}; $f++) {
	    if (!$self->{ADDED}{$f}) {
		print CANDIDATES "$self->{CANDIDATE_NAMES}[$f]\t";
	    }
	}
	print CANDIDATES "\n";

	# write candidates that were not added
	for ($x = 0; $x < $self->{NR_CLASSES}; $x++) {
	    for ($f = 0; $f < $self->{NR_CANDIDATES}; $f++) {
		if (!$self->{ADDED}{$f}) {
		    print CANDIDATES $self->{CANDIDATES}[$x]->bit_test($f);
		}
	    }
	    print CANDIDATES "\n";
	}

	close CANDIDATES;
	print "Closed $file\n";
    }
}


sub clear {
    my($self) = @_;

    undef $self->{ADDED};
}

1;

__END__