#!/usr/bin/perl -w

# "Generalized average precision" (GAP) scoring script for
# GermEval 2015: LexSub <https://sites.google.com/site/germeval2015>
# 
# Reference: Kazuaki Kishida.  Property of Average Precision and Its
# Generalization: An Examination of Evaluation Indicator for
# Information Retrieval Experiments. NII technical report. National
# Institute of Informatics, 2005.
# <http://www.nii.ac.jp/TechReports/05-014E.pdf>
#
# Copyright 2015 Technische Universität Darmstadt
# This program may be freely redistributed and modified for any purpose.
# It is distributed WITHOUT ANY WARRANTY, including warranties on TITLE,
# NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE.

# usage 
if (@ARGV < 2) {die "usage: perl scoreGAP.pl rankedfile goldfile [-v]\n\t goldfile: one scoring item per line in the format\n\t\t word.pos id :: subst1 weight1;subst2 weight2; ... ;substn weightn\n\t rankedfile: one item per line with a ranked list of substitutions in the format\n\t\tword.pos id :::: subst1;subst2; ... ;substn\n\t optional: -v for verbose output\n";}
 
# set verbose flag 
my $V=0;
if ((@ARGV >2)&&($ARGV[2] eq "-v")) {$V=1;}
if ((@ARGV >3)&&($ARGV[3] eq "-v")) {$V=1;}

# set info flag 
my $I=0;
if ((@ARGV >2)&&($ARGV[2] eq "-i")) {$I=1;}
if ((@ARGV >3)&&($ARGV[3] eq "-i")) {$I=1;}
 
 

# read gold items and pre-compute normalization for the ideal ranking
my %gold=(); # hashtable with key=word.pos\tid\tresult, value=weight
my %goldnorm=(); # hashtable with key=word.pos\tid value = normalizing factor R' for ideal ranking
my $nr=0;  # linenumber
open(F,"<$ARGV[1]")||die("  [ERROR] Gold not found: '$ARGV[1]'");
while(my $line=<F>) {
	$nr++;
	chomp($line);
	if (length($line)>0) {
		my @a=split(/ :: /,$line);
		if (@a ne 2) { if ($V>0) {print "  [Warning] ignoring malformed gold line $nr '$line'\n"}}
		else {
			#ignore leading and trailing whitespace
			$a[0]=~s/^\s+//; $a[0]=~s/\s+$//;
			my @b=split(/\s+/,$a[0]);
			if (@b ne 2) { if ($V>0) {print "  [Warning] ignoring malformed gold key, line $nr '$line'\n"}}
			else {
				my $w_id=$b[0]."\t".$b[1];
				my @scores=(); # collects scores for this answer
				my @ans=split(/;/,$a[1]);
				for(my $i=0;$i<@ans;$i++) {
					#ignore leading and trailing whitespace
					$ans[$i]=~s/^\s+//; $ans[$i]=~s/\s+$//;
					if (length($ans[$i])>0) {
						my @c=split(/\s+/,$ans[$i]);
						if ((@c < 2)||(!($c[@c-1]=~m/[0-9]+/))) { if ($V>0) {print "  [Warning] ignoring malformed gold answer '$ans[$i]' line $nr '$line'\n"}}
						else {
							my $answer=$c[0];
							for(my $k=1;$k<@c-1;$k++) {$answer.=" ".$c[$k];}
							$gold{$w_id."\t".$answer}=$c[@c-1];
							$scores[@scores]=$c[@c-1];
							if ($I>0) {print "  [info] Setting ".$w_id."->".$answer."=".$gold{$w_id."\t".$answer}."  line $nr '$line'\n"}
						}
					}
				} # rof anwers
				
				# compute normalizing factor
				my $sum=0.0;
				my @sortscores=(sort {$b <=> $a} @scores);
				for(my $s=0;$s<@sortscores;$s++) {
					for(my $k=0;$k<=$s;$k++) {
						$sum+=$sortscores[$k]*1.0/($s+1.0); 
					}
				}
				if ($sum>0.0) {
					if ($I>0) {print "  [info] normalizing factor for $w_id is $sum,  line $nr '$line'\n"}
					$goldnorm{$w_id}=$sum;
				} else {
					if ($V>0) {print "  [Warning] ignoring item, no valid answers in line $nr '$line'\n"}
				}
				
			}
		} # fi malformed split
	} # fi length>0 line not empty
}  # elihw
close(F);

# read and score system answers

my $golditems=(keys %goldnorm); # number of gold items successfully read from gold standard
my $attempted=0; # counts nr of attepted substitutions that have gold items
my $gapsum=0.0; # collects sum of individual gap scores


$nr=0; # linenumber
open(F,"<$ARGV[0]")||die("  [ERROR] System answers not found: '$ARGV[0]'");
while(my $line=<F>) {
	$nr++;
	chomp($line);
	if (length($line)>0) {
		my @a=split(/ :::: /,$line);
		if (@a ne 2) { if ($V>0) {print "  [Warning] ignoring malformed system line $nr '$line'\n"}}
		else {
			my @b=split(/\s+/,$a[0]);
			if (@b ne 2) { if ($V>0) {print "  [Warning] ignoring malformed answer key, line $nr '$line'\n"}}
			else {
			
				my $w_id=$b[0]."\t".$b[1];
				if (!defined $goldnorm{$w_id}) {if ($V>0) {print "  [Warning] ignoring system answers for '$w_id': undefined or multiply attempted gold item $nr '$line'\n"} }
				else {
					$attempted++; # all sytem answers with corrrect IDs count
					my @scores=(); # collects scores for this answer
					my @ans=split(/;/,$a[1]);
					my $spos=-1; my %seen=(); # handle duplicates
					for(my $i=0;$i<@ans;$i++) {
						#ignore leading and trailing whitespace
						$ans[$i]=~s/^\s+//; $ans[$i]=~s/\s+$//;
						if (defined $seen{$ans[$i]}) { if ($V>0) {print "  [Warning] ignoring duplicate system answer '$ans[$i]' for '$w_id' in line $nr '$line'\n"} }
						else { 
							$seen{$ans[$i]}=1;
							$spos++;
							if (defined ($gold{$w_id."\t".$ans[$i]})) {
								if ($I>0) { print "  [info] scoring '$w_id -> $ans[$i] with weight ".$gold{$w_id."\t".$ans[$i]}." at rank ".($i+1)." ' $line \n"}
								$scores[$spos]=$gold{$w_id."\t".$ans[$i]};
							} else {
								if ($I>0) { print "  [info] scoring '$w_id -> $ans[$i] with weight 0 (not found) at rank ".($i+1)." ' $line \n"}
								$scores[$spos]=0;
							}
						} # ignore duplicates
					} # rof answers
			
					# compute GAP score
					my $prenormsum=0.0;
					for (my $s=0;$s<@scores;$s++) {
						if ($scores[$s]>0) {
							for(my $k=0;$k<=$s;$k++) {
								$prenormsum+=$scores[$k]*1.0/($s+1.0); 
							}
						}
					}
					my $gap=$prenormsum/$goldnorm{$w_id};
					if ($V+$I>0) {print "  [verbose] gap for $w_id is $prenormsum / $goldnorm{$w_id} = $gap,  line $nr '$line'\n"}
					$gapsum+=$gap;
					delete $goldnorm{$w_id}; # do not allow same item to be scored twice		
				} # esle in gold standard 
			} # fi malformed answer key
		} # fi malformed split
	} # fi length>0 line not empty
} # elihw
close(F);

# final results
my $avggap=$gapsum/(1.0*$golditems);

print "GAP scorer results\n";
print "  $golditems from $ARGV[1]\n";
print "  $attempted attepted in $ARGV[0]\n";
print "  average GAP score:\t".$avggap."\n\n";

