| $_[1]: %s | %s | %s | %s | %3.2f | \n", $pair, $pairs{$key}, $frqc1, $frqc2, $_[0];
$results{$key}{$_[1]}=$result;
++$bestresults{$key};
}
sub parsestring {
if ($key=~/^(.+)~~(.+)$/) {
$frqc1=$frqc{$1};
$frqc2=$frqc{$2};
if ($sort2option eq 'left') {$pair="$2 $1"; ($frqc1,$frqc2)=($frqc2,$frqc1)
} elsif ($sort2option eq 'right') {$pair="$1 $2"
} else {$pair="$1/$2"};
if (($curlang eq 'ru') and (! $transliterateout)) {
$pair=&lat2cyr($pair);
};
} else { #?? any real cases
$frqc1=0;
$frqc2=0;
};
}
sub opencorpus {
my ($sourcecorpus)=@_;
$cqpquery = new CQP;
$cqpquery->set_error_handler(\&cqperror);
$cqpquery->exec($sourcecorpus);
$cqpquery->exec("set context $contextsize $contexttype");
$cqpquery->exec("set autoshow on");
$cqpquery->exec("show +lemma");
$corpus = new CL::Corpus $sourcecorpus; # open the CL interface
$word = $corpus->attribute("word", 'p');
$lemma = $corpus->attribute("lemma", 'p');
$corpussize = $word->max_cpos;
}
sub cqperror {
grep {print "$_ \n"} @_;
die "query: $querystring\n";
}
sub readstoplist {
open(LIST,$_[0]);
@stemlines=;
$stemlines=join ' ',@stemlines;
$stemlines=~s/$nw/ /;
@stemlines=split ' ',$stemlines;
@stoplist{@stemlines}=();
delete($stoplist{''});
}
sub loglike {
my ($k,$n,$x)=@_;
my $res=1000;
if (($x>0) and ((1-$x)>0)) {
$res = $k*log($x) + ($n-$k)*log(1-$x);
} else { $res=0;
# the case of complete dependence: one does not occur without the other, but log(0)
}
return($res);
}
sub processpattern {
my ($searchstring)=@_;
$cqpstart=time();
@matches = $cqpquery->query($searchstring);
$cqpprocesstime+=time()-$cqpstart;
if ($cqpquery->ok) {
foreach $m (@matches) {
if (processmatch($m)) { # otherwise we're dealing with a parallel text or an error
$matchlemma=getlemmas($match);
if ($sort2option eq 'left') {
$nlemma=getlemma($leftoutput);
$nword=getwords($leftoutput);
} else {
$nlemma=getlemma(split(' ',$rightoutput,1));
$nword=getwords(split(' ',$rightoutput,1));
};
next if (exists $stoplist{$nlemma}) or ($nlemma=~/[^a-z-]/i); # exclude stopwords or nonwords
if ($nonpattern) {
next if $nword=~/$nonpattern/;
};
++$pairs{"$matchlemma~~$nlemma"};
++$totalpairs;
}
};
} else {cqperror("Error in querying $searchstring")};
$numwords=$corpussize;
foreach $key (keys %pairs) {
next if ($pairs{$key}<$idiosyncthreshold);
unless (($matchlemma,$nlemma)=$key=~/^(.+)~~(.+)$/) {
cqperror("Internal error in splitting the collocation pair $_");
};
$onetwofrqc=$pairs{$key};
$onefrqc = scalar(@matches);
$frqc{$matchlemma}=$onefrqc unless exists $frqc{$matchlemma};
$id = $lemma->str2id($nlemma);
if ($id) {
$twofrqc = $lemma->id2freq($id);
$frqc{$nlemma}=$twofrqc unless exists $frqc{$nlemma};
$miscore{$key} = log ($numwords * $onetwofrqc /
($onefrqc * $twofrqc))/$log2; # log is the natural logarithm
$tscore{$key} = ($onetwofrqc - ($onefrqc * $twofrqc/$numwords)) /
sqrt ($onetwofrqc); # * $numwords
#the log like score according to Manning and Schuetze
$p=$twofrqc/$numwords;
$p1=$onetwofrqc /$onefrqc;
$p2=($twofrqc-$onetwofrqc)/($numwords-$onefrqc);
$loglikescore{$key}=-0.5*(&loglike($onetwofrqc, $onefrqc, $p) +
&loglike($twofrqc-$onetwofrqc, $numwords-$onefrqc, $p)-
&loglike($onetwofrqc, $onefrqc, $p1) -
&loglike($twofrqc-$onetwofrqc, $numwords-$onefrqc, $p2));
};
}
}
sub processmatch {
my $m=$_[0];
$m=~s/<\/?(s)>\/__UNDEF__/.<$1>/g; # we can't process HTML tags
if (($curpos,$leftoutput,$match,$rightoutput)=$m=~/(\d+):\s+(.+?)<(.+?)>(.+)/) {
return 1
} else {cqperror("Internal error in processing $m\n")}
}
sub getwords {
my $out='';
foreach (@_) {
if (/(.+?)\//) {
$out.="$1 ";
}
}
return $out;
}
sub getlemmas {
my $out='';
my @lemmas=split ' ',$_[0];
foreach (@lemmas) {
$out.=getlemma($_).' ';
};
return substr($out,0,length($out)-1); # minus the last space.
}
sub getlemma {
if ($_[0]=~/\/(\S+)/) {
return $1;
} else {return "xxx"}
}
__END__
=head1 NAME
mwedetect.pl - A tool for detecting the most salient multiword expressions
=head1 SYNOPSIS
perl mwedetect.pl -n BNC -s stoplist.txt -m MTL -i inputpatterns -o output.html
=head1 DESCRIPTION
The script takes a corpus stored in the CWB format and outputs the
most salient multiword expressions according to patterns specified in
the input file. Three metrics are used B
(MI-score), B (LL-score) and B
(T-score). The MI score tends to select those lexical items that are
rarely used without the second expression. In contrast, the T-score
is conservative: it tends to select the most frequent collocations,
weighting them according to the difference between the observed and
expected frequencies. Three CWB attributes are required in a corpus:
word, lemma and pos.
=head2 Parameters
-name Corpus name (as registered in CWB, required)
-cutoff Maximal number of collocates (default 100)
-input File with input patterns (one pattern per line)
-language Language (as for now, only 'ru' is used for transliteration of input patterns)
-metrics Metrics used for calculation. Three metrics can be used (and combined): mutual information (M), t-test (T) and loglikelihood (L), for instance, -m MT for MI and T scores
-output Output file (in HTML)
-pattern Pattern for words NOT to be considered, e.g. for capitalised words ^[A-Z]
-stop File with the list of stop words
-threshold Minimal number of occurrennces for each pattern to be considered in the output (default 20)
-window Position of the collocate with respect to the pattern: left, right (default) or window size
=head2 Format of patterns
Patterns are expressed in the same format as normal queries in CQP. Check the CQP manual at http://www.ims.uni-stuttgart.de/projekte/CorpusWorkbench/CQPUserManual/HTML/
=head1 COPYRIGHT
Copyright 2004, Serge Sharoff (Centre for Translation Studies, University of Leeds, UK).
You may use, redistribute and modify this tool under
the same license as Perl itself.
|