mrep.pl

This is SvmFu, a package for training and testing support vector machines (SVMs). It s written in C

# mrep - multiclass report for SvmFu
#
#  generates useful reports and predictions 
#  from SvmFu test output and split matrix files

use strict;
use Getopt::Long;

my ($infile, $splitsfile, $nolabel, $rows, $cols, $help, $loss, $report, 
    $errtype);
my (@splits, @predictions, @labels);

sub usage {
    print "mrep [options] splitsfile [infile, -]\n";
    print "\n";
    print "Options:\n";
    print "--report=[list, errors, confusion, accuracy] default: accuracy\n";
    print "--loss=[hinge, zero-one] default: hinge\n";
    print "--error-type=[no-tie,allow-tie,ratio] default: no-tie\n";
    print "--nolabel\n";
}

GetOptions('nolabel' => \$nolabel,
	   'loss|l=s' => \$loss,
	   'report|r=s' => \$report,
	   'error-type|e=s' => \$errtype,
	   'help' => \$help);
$splitsfile = shift;
$infile = shift;

# Option integrity checks
if ($help) {
    &usage;
    exit;
}
if (!defined $splitsfile) {
    &usage;
    exit;
}
if (!defined $infile) {
    $infile = '-';
}
if (!defined $loss) {
    $loss = 'hinge';
}
if (!defined $errtype) {
    $errtype = 'no-tie';
}
if (!defined $report) {
    $report = 'accuracy';
    if ($nolabel) { print "Cannot use report $report with no label\n"; } 
}
if (($report eq 'error' or $report eq 'confusion' or $report eq 'accuracy') 
    and $nolabel) {
    print STDERR "Cannot use report $report and no label\n";
    $report = 'list'; 
    print STDERR "Using report type: $report\n";
 
}

### Subroutines ###

# Print confusion matrix

sub p_confusion {
   my ($predref, $labelsref, $cols, $i, $j) = @_;
   my @c;
   
   format ENTRY =
@# |@>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>>
$i, @{$c[$i]}
.

    my @lbl;
    format HEAD =
   |@>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>> @>>
@lbl
.

   # Fill confusion
   
   for $i ( 0 .. $#{$labelsref} ) {
       for $j (0 .. $#{@$predref[$i]}) {
	   $c[$$labelsref[$i]][$$predref[$i][$j]]++;	   
       }
   }
   
   if ($cols > 15) { print STDERR "Warning: only showing first 16 classes\n"; }
   
   # Print confusion
@lbl = (0 .. $cols);
for $i (0 .. 15) {
    if (!defined $lbl[$i]) {
	$lbl[$i] = '';
    }
}
$~="HEAD";
write;
   print "---+";
for $i ( 0 .. $cols) {
    print "---+";
}
print "\n";
   for $i ( 0 .. $cols ) {
       for $j ( 0 .. 15 ) {
	   if (!defined $c[$i][$j] ) {
	       if ($j <= $cols) {
		   $c[$i][$j] = 0;
	       } else {
		   $c[$i][$j] = ' ';
	       }
	   }
       }
       #print "$c[$i][$j] ";
       $~="ENTRY";
       write;
   }
}

# Print a list of errors, true class then false classes
sub p_error {
    my ($predref, $labelsref) = @_; 

    my $err = 0; #error flag
    for my $i ( 0 .. $#{$predref}) {
	#check to see if predictions do not match label
	for my $j ( 0 .. $#{@$predref[$i]}) {
	    last if $err;
	    #if they don't, set the error flag
	    if ($$predref[$i][$j] != $$labelsref[$i]) { 
	    	$err++;
	    }
	}
	print $$labelsref[$i] . " " . "@{$$predref[$i]}" . "\n" if $err;
	$err = 0; # reset error flag
    }
	    
}

# Print a list of predictions
sub p_list(@pred) {
    my ($predref) = @_;
    
    foreach my $pred (@$predref) {
	print "@$pred\n";
    }
}

# Hinge loss
# (1-YiFi)+

sub l_hinge {
    my ($pointref, $splitref) = @_;
    my ($l, $f, $l_acc);
    my (@pred);

    $f = -1;
    $l = 0;

    for my $i ( 0 .. $#{$$splitref[0]}) {
	$l_acc = 0;
  	for my $j ( 0 .. $#{$splitref} ) {
  	    $l_acc += max(1 - $$splitref[$j][$i] * $$pointref[$j], 0);
  	}
  	if ($f == -1 || $l_acc < $l) {
  	    $l = $l_acc;
  	    $f = 1;
  	    @pred = ($i);
    	} elsif ($l_acc == $l) {
    	    push @pred, $i;
    	}
    }

    return @pred;
}

# Zero one loss
#  1: if agree but not zero
# .5: if agree but zero
#  0: otherwise

sub l_zero {
    my ($pointref, $splitref) = @_;
    my ($l, $l_acc, $f);
    my (@pred);

    $l = 0;
    $f = -1;
    for my $i ( 0 .. $#{$$splitref[0]}) {
	$l_acc = 0;
	for my $j ( 0 .. $#{$splitref} ) {
	    if ( $$splitref[$i][$j] != sign($$pointref[$j]) ) {
		if ($$splitref[$i][$j] == 0) {
		    $l_acc += 0.5;
		} else {
		    $l_acc += 1;
		}
	    }
	}
	if ($f == -1 || $l_acc < $l) {
	    $l = $l_acc;
	    $f = 1;
	    @pred = ($i);
	} elsif ($l_acc == $l) {
	    push @pred, $i;
	}
    }
    return @pred;
}

# Return the max of two values
sub max {
    my ($a, $b) = @_;

    if ($a > $b) {
	return $a;
    } else {
	return $b;
    }
}

# Return the sign (1 or -1) of a number 
sub sign {
    my ($a) = @_;

    if ($a < 0) {
	return -1;
    } else {
	return 1;
    }
}

# Read Splits Matrix
sub readSplits {
    my $splits = shift;
    my ($rows, $cols, $i, $class);
    my (@ret);

    open(SPLITS, "< $splits") or die("Error opening splitsfile: $!");

    $_ = <SPLITS>;
    ($rows, $cols) = split;
    
    while(<SPLITS>) {
	push @ret, [ split ];
    }
    
    return @ret;
}

### Main ###

# Read Splits file
@splits = readSplits($splitsfile);
$cols = $#{$splits[0]};

# Open and read infile
open(IN, "<$infile") or die("Error opening infile: $!\n");

my $errors = 0;
while(<IN>) {
    my ($label);
    my (@point, @pred);
    
    if ($nolabel) {
	@point = split;
	$label = '*nolabel*'; # Fill label with a dummy val
    } else {
	($label, @point) = split;
    }
    
    # Compute this point's loss
    # @pred is an array for all predictions of this point. 
    # it has multiple values when the loss function ties.


    if ($loss eq 'hinge') {
	@pred = l_hinge(\@point, \@splits);
    } elsif ($loss eq 'zero-one') {
	@pred = l_zero(\@point, \@splits);
    } else { # Base case is to use hinge loss
	print STDERR "Unspecifed loss type: $loss. Using hinge.\n";
	$loss = 'hinge';
	@pred = l_hinge(\@point, \@splits);
    }

    # Count errors
    #
    # an error is when there is no prediction that matches the label for this 
    # point.

    unless ($nolabel) {
	if ($errtype eq 'no-tie') {
	    if(!($pred[0] == $label && $#pred == 0)) {
		$errors++;
	    }
	}
	if ($errtype eq 'ratio') {
	    my ($c, $e) = (0, 0);
	    foreach my $pred (@pred) {
		if ($pred == $label) {
		    $c++;
		} else {
		    $e++;
		}
	    }
	    $errors += $e / ($c+$e);
	}
	if ($errtype eq 'allow-tie') {
	    my $iserr = 1;
	    foreach my $pred (@pred) {
		if ($pred == $label) {
		    $iserr = 0;
		    last;
		}
	    }
	    if ($iserr) {
		$errors++;
	    } 
	}
    }
    
    # Fill appropriate arrays. 
    push @predictions, [ @pred ]; #@predictions is a 2D array
    push @labels, $label unless $nolabel;

}
 
sub p_stats {
    my ($points, $errors) = @_;
    print "Points: " . $points . "\n";
    printf "Errors: %d (%.3f%% correct)\n", $errors, (1.0 - ($errors/$points)) * 100;
    print "\n";
}

# Report type dispatch
if ($report eq 'list') {
    p_list(\@predictions);
} elsif ($report eq 'errors') {
    p_stats($#labels+1, $errors) unless $nolabel;
    p_error(\@predictions, \@labels);
} elsif ($report eq 'confusion') {
    p_stats($#labels+1, $errors) unless $nolabel;
    p_confusion(\@predictions, \@labels, $cols);
} elsif ($report eq 'accuracy') {
    p_stats($#labels+1, $errors) unless $nolabel;
}