#!/usr/bin/env perl
#-*-perl-*-
#
#---------------------------------------------------------------------------
# Copyright (C) 2004 Jörg Tiedemann <joerg@stp.ling.uu.se>
#
# This program 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 program 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 General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#---------------------------------------------------------------------------
use strict;
use FindBin qw($Bin);
use lib "$Bin/../lib";
use Uplug::IO::Any;
use Uplug::Data;
use Uplug::Config;
my $beta=1; # default: P and R are equally important
#---------------------------------------------------------------------------
# 0) get input parameter
my %IniData=&GetDefaultIni;
my $IniFile='evalalign.ini';
&CheckParameter(\%IniData,\@ARGV,$IniFile);
my $GoldStream;my $AlignStream;
foreach (keys %{$IniData{input}}){
if (/(gold|reference)/){
$GoldStream=$IniData{input}{$_};
}
else{
$AlignStream=$IniData{input}{$_};
}
}
my $minscore=$IniData{parameter}{'minimal score'};
if (defined $IniData{parameter}{'F-beta'}){
$beta=$IniData{parameter}{'F-beta'};
}
#---------------------------------------------------------------------------
# 1) read links from the gold standard
my $gold=Uplug::IO::Any->new($GoldStream);
$gold->open('read',$GoldStream);
my %GoldLinks=();
&ReadGoldStandard($gold,\%GoldLinks);
$gold->close();
#---------------------------------------------------------------------------
# 2) go through the alignment file and compare links with the gold standard
my $align=Uplug::IO::Any->new($AlignStream);
$align->open('read',$AlignStream);
my $data=Uplug::Data->new();
my %counts=();
while ($align->read($data)){
my $id=$data->attribute('id','sentLink');
if (not $id){$id=$data->attribute('id','link');}
if (not defined $GoldLinks{$id}){next;}
&CheckLinks($data,$GoldLinks{$id},\%counts,$id,$minscore);
}
$align->close();
#---------------------------------------------------------------------------
# 3) calculate some evaluation measures and print them
my %precision_pwa;
my %recall_pwa;
my %F_pwa;
my %precision;
my %recall;
my %F;
$counts{regular}{correctness}=
$counts{regular}{Q}+$counts{regular}{null}+$counts{regular}{correct};
$counts{fuzzy}{correctness}=
$counts{fuzzy}{Q}+$counts{fuzzy}{null}+$counts{fuzzy}{correct};
$counts{regular}{recall}=
$counts{regular}{QR}+$counts{regular}{null}+$counts{regular}{correct};
$counts{fuzzy}{recall}=
$counts{fuzzy}{QR}+$counts{fuzzy}{null}+$counts{fuzzy}{correct};
$counts{regular}{precision}=
$counts{regular}{QP}+$counts{regular}{null}+$counts{regular}{correct};
$counts{fuzzy}{precision}=
$counts{fuzzy}{QP}+$counts{fuzzy}{null}+$counts{fuzzy}{correct};
foreach (keys %{$counts{regular}}){
$counts{all}{$_}=$counts{regular}{$_}+$counts{fuzzy}{$_};
}
# just in case some keys don't exist for regular:
foreach (keys %{$counts{fuzzy}}){
$counts{all}{$_}=$counts{regular}{$_}+$counts{fuzzy}{$_};
}
foreach ('regular','fuzzy','all'){
if ($counts{$_}{goldsize}){
$recall_pwa{$_}=$counts{$_}{correctness}/$counts{$_}{goldsize};
$recall{$_}=$counts{$_}{recall}/$counts{$_}{goldsize};
my $aligned=$counts{$_}{goldsize}-$counts{$_}{missing};
if ($aligned){
$precision_pwa{$_}=$counts{$_}{correctness}/$aligned;
$precision{$_}=$counts{$_}{precision}/$aligned;
}
if ($precision_pwa{$_}+$recall_pwa{$_}){
$F_pwa{$_}=(($beta*$beta+1)*$precision_pwa{$_}*$recall_pwa{$_})/
($beta*$beta*$precision_pwa{$_}+$recall_pwa{$_});
# $F_pwa{$_}=(2*$precision_pwa{$_}*$recall_pwa{$_})/
# ($precision_pwa{$_}+$recall_pwa{$_});
}
if ($precision{$_}+$recall{$_}){
# $F{$_}=(2*$precision{$_}*$recall{$_})/
# ($precision{$_}+$recall{$_});
$F{$_}=(($beta*$beta+1)*$precision{$_}*$recall{$_})/
($beta*$beta*$precision{$_}+$recall{$_});
}
}
}
print "------------------------------------------------------\n";
if ($counts{all}{correct}){
print " average score for correct links: ",
$counts{all}{correctscore}/$counts{all}{correct},"\n";
}
if ($counts{all}{nrpartial}){
print "average score for partially correct links: ",
$counts{all}{partialscore}/$counts{all}{nrpartial},"\n";
}
if ($counts{all}{nrwrong}){
print " average score for incorrect links: ",
$counts{all}{wrongscore}/$counts{all}{nrwrong},"\n";
}
print "------------------------------------------------------\n";
printf "%25s: %4d, regular:%4d,fuzzy:%4d,null:%4d\n",
"size of gold standard",$counts{all}{goldsize},
$counts{regular}{goldsize},$counts{fuzzy}{goldsize},$counts{all}{nrnull};
printf "%25s: %4d, regular:%4d,fuzzy:%4d,null:%4d\n",
"correct links",$counts{all}{correct}+$counts{all}{null},
$counts{regular}{correct},$counts{fuzzy}{correct},$counts{all}{null};
printf "%25s: %4d, regular:%4d,fuzzy:%4d\n",
"partially correct links",$counts{all}{partial},
$counts{regular}{partial},$counts{fuzzy}{partial};
printf "%25s: %4d, regular:%4d,fuzzy:%4d,null:%4d\n",
"incorrect links",$counts{all}{incorrect},$counts{regular}{incorrect},
$counts{fuzzy}{incorrect},$counts{all}{incorrectnull};
printf "%25s: %4d, regular:%4d,fuzzy:%4d\n",
"missing links",$counts{all}{missing},
$counts{regular}{missing},$counts{fuzzy}{missing};
print "------------------------------------------------------\n";
printf "%10s: %3.2f\%","recall",$recall{all}*100;
printf " (regular: %3.2f\%",$recall{regular}*100;
printf ",fuzzy: %3.2f\%",$recall{fuzzy}*100;
printf ",pwa: %3.2f\%)\n",$recall_pwa{all}*100;
printf "%10s: %3.2f\%","precision",$precision{all}*100;
printf " (regular: %3.2f\%",$precision{regular}*100;
printf ",fuzzy: %3.2f\%", $precision{fuzzy}*100;
printf ",pwa: %3.2f\%)\n",$precision_pwa{all}*100;
printf "%10s: %3.2f\%","F",$F{all}*100;
printf " (regular: %3.2f\%",$F{regular}*100;
printf ",fuzzy: %3.2f\%",$F{fuzzy}*100;
printf ",pwa: %3.2f\%)\n",$F_pwa{all}*100;
#---------------------------------------------------------------------------
# CheckLinks: compare alignments with links from the gold standard
sub CheckLinks{
my ($data,$gold,$counts,$id,$score)=@_;
my @n=$data->findNodes('wordLink');
# if (not @n){return;}
my %links=();
foreach (0..$#n){
&SplitLink($data,$n[$_],\%links,$score);
}
foreach my $l (keys %{$gold}){
if ($l eq 'src'){next;}
if ($l eq 'trg'){next;}
my $type=$$gold{$l}{type};
if ($type eq 'null'){$type='fuzzy';}
my $srclex=join ' ',@{$$gold{$l}{srclex}};
my $trglex=join ' ',@{$$gold{$l}{trglex}};
printf "%15s: %25s - %-25s ",$id,$srclex,$trglex;
$$counts{$type}{goldsize}++;
if (not @{$$gold{$l}{trg}}){ # check for null links:
$$counts{$type}{nrnull}++; # count null links
if (defined $links{src}{$$gold{$l}{src}[0]}){ # aligned null links:
$$counts{$type}{incorrectnull}++; # -> incorrect
}
else{
$$counts{$type}{null}++; # count not aligned null links
print "null\n"; # (= correct)
next;
}
}
if (defined $links{$l}){ # link exists exactely like in the
$$counts{$type}{correct}++; # gold standard
$$counts{$type}{correctscore}+=$links{$l}{type};
print "correct\n";
next;
}
#----------------------------------------------------------------------
# check partialially correct links
my %PartialLinks=();
foreach my $s (@{$$gold{$l}{src}}){
if (defined $links{src}{$s}){
$PartialLinks{$links{src}{$s}}=1;
}
}
foreach my $t (@{$$gold{$l}{trg}}){
if (defined $links{trg}{$t}){
$PartialLinks{$links{trg}{$t}}=1;
}
}
my $NrCorrSrc=0;
my $NrCorrTrg=0;
my $NrLinkSrc=0;
my $NrLinkTrg=0;
my $LinkedSrc=''; # links proposed by the system
my $LinkedTrg='';
my $NrGoldSrc=$#{$$gold{$l}{src}}+1;
my $NrGoldTrg=$#{$$gold{$l}{trg}}+1;
foreach (keys %PartialLinks){
$NrLinkSrc+=$#{$links{$_}{src}}+1;
$NrLinkTrg+=$#{$links{$_}{trg}}+1;
my $corrSrc=&NrIdentical($links{$_}{src},$$gold{$l}{src});
my $corrTrg=&NrIdentical($links{$_}{trg},$$gold{$l}{trg});
if ($corrSrc and $corrTrg){
$NrCorrSrc+=$corrSrc;
$NrCorrTrg+=$corrTrg;
$$counts{$type}{partialscore}+=$links{$_}{type};
$$counts{$type}{nrpartial}++;
}
elsif ($corrSrc or $corrTrg){
$$counts{$type}{wrongscore}+=$links{$_}{type};
$$counts{$type}{nrwrong}++;
}
$LinkedSrc.='|';
$LinkedTrg.='|';
$LinkedSrc.=join ' ',@{$links{$_}{srclex}};
$LinkedTrg.=join ' ',@{$links{$_}{trglex}};
}
if (not keys %PartialLinks){
$$counts{$type}{missing}++;
print "missing\n";
next;
}
my $NrSrc=$NrGoldSrc;
my $NrTrg=$NrGoldTrg;
if ($NrLinkSrc>$NrGoldSrc){$NrSrc=$NrLinkSrc;}
if ($NrLinkTrg>$NrGoldTrg){$NrTrg=$NrLinkTrg;}
my $NrCorr=($NrCorrSrc+$NrCorrTrg);
my $NrTok=($NrSrc+$NrTrg);
if ($NrCorr and $NrTok){
$$counts{$type}{Q}+=($NrCorrSrc+$NrCorrTrg)/($NrSrc+$NrTrg);
$$counts{$type}{QR}+=
($NrCorrSrc+$NrCorrTrg)/($NrGoldSrc+$NrGoldTrg);
$$counts{$type}{QP}+=
($NrCorrSrc+$NrCorrTrg)/($NrLinkSrc+$NrLinkTrg);
$$counts{$type}{partial}++;
print "$NrCorr($NrTok)\n";
}
elsif(not $NrCorr){
$$counts{$type}{incorrect}++;
print "wrong\n";
}
$LinkedSrc.='|';
$LinkedTrg.='|';
printf "%42s - %-30s\n",$LinkedSrc,$LinkedTrg;
}
}
#---------------------------------------------------------------------------
# NrIdentical: compare 2 sets and return the number of identical elements
sub NrIdentical{
my ($set1,$set2)=@_;
my $nr=0;
foreach my $i (@{$set1}){
if (grep ($_ eq $i,@{$set2})){$nr++;}
}
return $nr;
}
sub ReadGoldStandard{
my ($stream,$links)=@_;
my $data=Uplug::Data->new();
while ($stream->read($data)){
my $id=$data->attribute('id','sentLink');
if (not $id){$id=$data->attribute('id','link');}
my @n=$data->findNodes('wordLink');
if (not @n){next;}
print STDERR '.';
$$links{$id}={};
foreach (0..$#n){
&SplitLink($data,$n[$_],$$links{$id});
}
}
}
#---------------------------------------------------------------------------
# get link-information from the XML data-object
sub SplitLink{
my ($data,$node,$link,$score)=@_;
my $xtrg=$data->attribute($node,'xtargets');
my $lex=$data->attribute($node,'lexPair');
my $type=$data->attribute($node,'certainty');
if (not $type){$type='regular';}
if (defined $score){
if ($type<$score){return;}
}
$$link{$xtrg}{type}=$type;
my ($src,$trg)=split(/\;/,$xtrg);
@{$$link{$xtrg}{src}}=split(/\+/,$src);
@{$$link{$xtrg}{trg}}=split(/\+/,$trg);
my ($src,$trg)=split(/\;/,$lex);
@{$$link{$xtrg}{srclex}}=split(/\s/,$src);
@{$$link{$xtrg}{trglex}}=split(/\s/,$trg);
foreach (@{$$link{$xtrg}{src}}){$$link{src}{$_}=$xtrg;}
foreach (@{$$link{$xtrg}{trg}}){$$link{trg}{$_}=$xtrg;}
}
#---------------------------------------------------------------------------
sub GetDefaultIni{
my $DefaultIni = {
'input' => {
'gold standard' => {
'format' => 'xml',
'root' => '(link|sentLink)',
},
'alignments' => {
'format' => 'xml',
'root' => '(link|sentLink)',
}
},
'parameter' => {
'F-beta' => 1
},
'arguments' => {
'shortcuts' => {
'in' => 'input:alignments:file',
'gold' => 'input:gold standard:file',
'min' => 'parameter:minimal score',
'beta' => 'parameter:F-beta',
}
},
'widgets' => {
}
};
return %{$DefaultIni};
}