root/util/title_testharness @ 122

Revision 122, 14.8 kB (checked in by max, 7 years ago)

Compare algorithms.
  • Property svn:executable set to *
Line 
1#!/usr/bin/perl -w
2
3#
4# test harness for evaluating different title-matching algorithms
5#
6
7use strict;
8$| = 1;
9
10use XMLTV;
11use POSIX qw(strftime mktime);
12use Getopt::Long;
13use Data::Dumper;
14use Time::HiRes qw(gettimeofday tv_interval);
15
16my %algorithms = (
17        'imdb_type' =>          \&alternativeTitles_match,
18        'canonicalize' =>       \&canonicalizeTitles_match,
19        # ... add more algorithms here ...
20        'simple_string' =>      \&string_match);
21
22my %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } );
23my $gmt_offset;
24my $num_programmes = 0;
25my $datafile, my $datafile_num = 0;
26my $prog_lineup;
27
28my $opt = { };
29GetOptions(
30        'create=s'              => \$opt->{create},
31        'show_non_matches'      => \$opt->{show_non_matches},
32        'show_matches'          => \$opt->{show_matches},
33        'test=s'                => \$opt->{test},
34        'compare=s'             => \$opt->{compare},
35        'help'                  => \$opt->{help});
36
37printf "tiele-matching test harness\n";
38if (($opt->{help}) || (!defined $opt->{test}) && (!defined $opt->{create}) && !defined $opt->{compare} ) {
39        print "  usage:\n".
40              "\t$0 --create (title_file) [FILE(s)]\n".
41              "\t\tcreate a listing of programmes from input xmltv files\n".
42              "\t\t(supplied from stdin or a list of files).\n".
43              "\t\tthe resulting {titles_file} can then be used as input\n".
44              "\t\tinto testing (--test) various title-matching algorithms\n".
45              "\n".
46              "\t$0 --test {algorithm|all} [--show_non_matches] [--show_matches]\n".
47              "\t\ttest the various title-matching algorithms based on\n".
48              "\t\tstdin from a list of titles {titles_file}.\n".
49              "\t\talgorithms:\n\t\t  '".join("'\n\t\t  '",sort keys %algorithms)."'\n";
50        exit(0);
51}
52
53@ARGV = ('-') if not @ARGV;
54$opt->{test} = $opt->{compare} if ($opt->{compare});
55&create_programme_lineup($opt->{create}) if ($opt->{create});
56&test_algorithms($opt->{test}) if ($opt->{test});
57
58exit(0);
59
60##############################################################################
61# descend a structure and clean up various things, including stripping
62# leading/trailing spaces in strings, translations of html stuff etc
63#   -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
64
65sub cleanup {
66        my $x = shift;
67        if    (ref $x eq "REF")   { cleanup($_) }
68        elsif (ref $x eq "HASH")  { cleanup(\$_) for values %$x }
69        elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
70        elsif (defined $$x) {
71                $$x =~ s/&(#(\d+)|(.*?));/ $2 ? chr($2) : $amp{$3}||' ' /eg;
72                # $$x =~ s/[^\x20-\x7f]/ /g;
73                $$x =~ s/(^\s+|\s+$)//g;
74        }
75}
76
77##############################################################################
78# strptime type date parsing - BUT - if no timezone is present, treat time as
79# being in localtime rather than the various other perl implementation which
80# treats it as being in UTC/GMT
81
82sub parse_xmltv_date
83{
84        my $datestring = shift;
85        my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
86        my $tz_offset = 0;
87
88        # work out GMT offset - we only do this once
89        if (!$gmt_offset) {
90                my @l = localtime(43200), my @g = gmtime(43200);
91                $gmt_offset = (($l[2] - $g[2])*(60*60)) + (($l[1] - $g[1])*60);
92        }
93
94        if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
95                ($t[5],$t[4],$t[3],$t[2],$t[1],$t[0]) = (int($1)-1900,int($2)-1,int($3),int($4),int($5),0);
96                ($t[6],$t[7],$t[8]) = (-1,-1,-1);
97
98                # if input data has a timezone offset, then offset by that
99                if ($datestring =~ /\+(\d{2})(\d{2})/) {
100                        $tz_offset = $gmt_offset - (($1*(60*60)) + ($2*60));
101                } elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
102                        $tz_offset = $gmt_offset + (($1*(60*60)) + ($2*60));
103                }
104
105                my $e = mktime(@t);
106                return ($e+$tz_offset) if ($e > 1);
107        }
108        return undef;
109}
110
111##############################################################################
112
113sub dontcare_cb( $ )
114{
115        return;
116}
117
118##############################################################################
119
120sub programme_cb( $ )
121{
122        my $prog=shift;
123        &cleanup($prog);
124        # print "got programme from $datafile: ".Dumper($prog);
125
126        # make sure programme has a title
127        if (!defined $prog->{title} || !defined $prog->{title}->[0]) {
128                printf STDERR "programme with no title in %s; ignored.", $datafile;
129                return;
130        }
131        my $prog_title = $prog->{title}->[0]->[0];
132
133        my $t = &parse_xmltv_date($prog->{start});
134
135        if (!$t) {
136                printf STDERR "programme '%s' from %s had invalid start time (%s); ignored",
137                  $prog_title, ($prog->{start} ? $prog->{start} : "undef");
138                return;
139        }
140
141        # make programme time within a half-hour increment (0-47)
142        my $inc = int((($t + $gmt_offset) % (60*60*24)) / (60*30));
143
144        # print out programmes half-hour increments (0-47) & programme title
145        printf O "%d\t%d\t%s\n",$datafile_num,$inc,$prog_title;
146
147        $num_programmes++;
148}
149
150##############################################################################
151
152sub create_programme_lineup
153{
154        my $output = shift;
155
156        if (!(open(O,">$output"))) {
157                die "could not create output file $output: $!\n";
158        }
159
160        printf STDERR "creating programme lineup in file $output\n";
161        printf O "# datafile_num\thalf-hour-slot\tprogramme_name\n";
162
163        foreach my $file (@ARGV) {
164                $datafile = $file;
165                printf STDERR "parsing: %s\n",($datafile eq "-" ?
166                  "(from-stdin, hit control-D to finiah)" : $datafile);
167                eval { XMLTV::parsefiles_callback(\&dontcare_cb, \&dontcare_cb,
168                  \&dontcare_cb, \&programme_cb, $datafile); };
169                $datafile_num++;
170        }
171
172        printf STDERR "finished, $num_programmes programmes from $datafile_num sources in $output\n";
173        close(O);
174}
175
176
177
178##############################################################################
179
180sub test_algorithms
181{
182        my $alg = shift;
183        printf STDERR "testing %s algorithm%s against programmes from stdin\n",
184          $alg, ($alg eq "all" ? "s" : "");
185
186        while (<STDIN>) {
187                chop;
188                next if ($_ =~ /^#/);
189                my ($n,$t,$p) = split(/\t/,$_);
190                push(@{($prog_lineup->[$t]->[$n])},$p);
191                $num_programmes++;
192                $datafile_num = $n if ($n > $datafile_num);
193        }
194        printf STDERR "%d programmes from %d sources across %d timeslots\n",
195                $num_programmes, $datafile_num, $#{$prog_lineup};
196
197        foreach my $a (sort keys %algorithms) {
198                if (($alg eq $a) || ($alg eq "all")) {
199                        # printf STDERR "testing algorithm '%s' against %d programmes\n", $a, $num_programmes;
200                        &test_alg($a);
201                }
202        }
203
204        &test_alg() if ($opt->{compare});
205
206        printf STDERR "\n";
207        printf STDERR "to see details on matches, use the --show_matches option.\n" unless $opt->{show_matches};
208        printf STDERR "to see details on non-matches, use the --show_non_matches option.\n" unless $opt->{show_non_matches};
209}
210
211##############################################################################
212
213sub test_alg
214{
215        my $alg = shift;
216        my $matches = 0;
217        my $non_matches = 0;
218        my $alg_start = [gettimeofday];
219
220        my ($al1, $al2);
221        if ($opt->{compare} and $opt->{compare} =~ /(.*),(.*)/) {
222            if ($algorithms{$1} and $algorithms{$2}) {
223                ($al1, $al2) = ($1, $2);
224                print "Comparing $al1 to $al2.\n";
225            }
226        }
227           
228        foreach my $timeslot (0..$#{$prog_lineup}) {
229                foreach my $source (0..$datafile_num) {
230                        next if (!defined $prog_lineup->[$timeslot]->[$source]);
231
232                        # within each timeslot, compare programmes between
233                        # data sources using the algorithm routine passed in
234                        my @c1 = @{($prog_lineup->[$timeslot]->[$source])};
235
236                        for my $source2 (0..$datafile_num) {
237                                next if ($source == $source2);
238                                next if (!defined $prog_lineup->[$timeslot]->[$source2]);
239
240                                my @c2 = @{($prog_lineup->[$timeslot]->[$source2])};
241
242                                # see how many matches we get between c1 and c2
243                                foreach my $prog1 (@c1) {
244                                        foreach my $prog2 (@c2) {
245
246                                                # No point comparing the same string, is there?
247                                                next if ($prog1 eq $prog2);
248
249                                                if ($al1 and $al2) {
250                                                    my $m1 = $algorithms{$al1}->($prog1,$prog2);
251                                                    my $m2 = $algorithms{$al2}->($prog1,$prog2);
252                                                    if ($m1 != $m2) {
253                                                        print "\"$prog1\" vs \"$prog2\": $al1 says " .
254                                                              ($m1 ? "MATCH" : "NON-MATCH") .
255                                                              " and $al2 says " .
256                                                              ($m2 ? "MATCH" : "NON-MATCH") . 
257                                                              ".\n";
258                                                    }
259                                                }
260                                                else {
261                                                    if ($algorithms{$alg}->($prog1,$prog2)) {
262                                                        printf "algorithm $alg said '$prog1' and '$prog2' DO match\n" if ($opt->{show_matches});
263                                                        $matches++;
264                                                    } else {
265                                                        printf "algorithm $alg said '$prog1' and '$prog2' don't match\n" if ($opt->{show_non_matches});
266                                                        $non_matches++;
267                                                    }
268                                                }
269                                        }
270                                }
271                        }
272                }
273        }
274
275        printf STDERR " - algorithm %s took %0.2fsec to record %d matches and %d non-matches.\n",
276          $alg, tv_interval($alg_start), $matches, $non_matches;
277}
278
279##############################################################################
280# simple string match
281
282sub string_match
283{
284        my ($s1,$s2) = @_;
285        return 1 if (lc($s1) eq lc($s2));
286        return 0;
287}
288
289##############################################################################
290# original alternativeTitles() from XMLTV::IMDB, this one knows about even more translations..
291
292sub alternativeTitles($)
293{
294        my $title=shift;
295        my @titles;
296
297        push(@titles, $title);  # seed with original title
298
299        # try "&" -> "and" conversion ('Spicks & Specks' => 'Spicks and Specks')
300        if ( $title=~m/\&/o ) {
301                my $t=$title;
302                push(@titles, $t) while ( $t=~s/(\s)\&(\s)/$1and$2/o );
303        }
304
305        # try the "and" -> "&" conversion ('Spicks and Specks' => 'Spicks & Specks')
306        if ( $title=~m/\sand\s/io ) {
307                my $t=$title;
308                push(@titles, $t) while ( $t=~s/(\s)and(\s)/$1\&$2/io );
309        }
310
311        # 'Barney  Friends' => 'Barney & Friends'
312        foreach my $t (@titles) {
313                if ($t =~ /^(.*)  (.*)$/) {
314                        push(@titles,"$1 & $2");
315                }
316        }
317
318        # 'Barney  Friends' => 'Barney - Friends'
319        foreach my $t (@titles) {
320                if ($t =~ /^(.*)  (.*)$/) {
321                        push(@titles,"$1 - $2");
322                }
323        }
324
325        # "Creflo A. Dollar, Jr" => "Creflo A Dollar"
326        # "House, M.D." => "House"
327        foreach my $t (@titles) {
328                push(@titles,"$1") if ($t =~ /^(.*), Jr$/);
329                push(@titles,"$1") if ($t =~ /^(.*), M\.D\.$/);
330        }
331
332        # "quotes" -> quotes
333        foreach my $t (@titles) {
334                push(@titles,$1) if ( $t =~ /^\"(.*)\"$/);
335        }
336
337        # remove full stops - e.g. will translate 'Dr. Dog.' to 'Dr Dog.' and 'Dr Dog'
338        foreach my $t (@titles) {
339                if ($t =~ /\./) {
340                        my @new_titles;
341                        push(@new_titles, $t) while ( $t=~s/(.*)\.(.*)/$1$2/io );
342                        push(@titles,@new_titles);
343                }
344        }
345
346        # remove dashes
347        foreach my $t (@titles) {
348                if ($t =~ /\-/) {
349                        my @new_titles;
350                        push(@new_titles, $t) while ( $t=~s/(.*)\-(.*)/$1$2/io );
351                        push(@titles,@new_titles);
352                }
353        }
354
355        # # strip *'s: "M*A*S*H" => "MASH";
356        foreach my $t (@titles) {
357                if ($t =~ /\*/) {
358                        my @new_titles;
359                        push(@new_titles, $t) while ( $t=~s/(.*)\*(.*)/$1$2/io );
360                        push(@titles,@new_titles);
361                }
362        }
363
364        # remove !s
365        foreach my $t (@titles) {
366                if ($t =~ /\'/) {
367                        my @new_titles;
368                        push(@new_titles, $t) while ( $t=~s/(.*)\'(.*)/$1$2/io );
369                        push(@titles,@new_titles);
370                }
371        }
372
373        # remove :s
374        foreach my $t (@titles) {
375                if ($t =~ /:/) {
376                        my @new_titles;
377                        push(@new_titles, $t) while ( $t=~s/(.*):(.*)/$1$2/io );
378                        push(@titles,@new_titles);
379                }
380        }
381
382        # remove apostrophies
383        foreach my $t (@titles) {
384                if ($t =~ /\!/) {
385                        my @new_titles;
386                        push(@new_titles, $t) while ( $t=~s/(.*)!(.*)/$1$2/io );
387                        push(@titles,@new_titles);
388                }
389        }
390
391        # remove commas
392        foreach my $t (@titles) {
393                if ($t =~ /\,/) {
394                        my @new_titles;
395                        push(@new_titles, $t) while ( $t=~s/(.*)\,(.*)/$1$2/io );
396                        push(@titles,@new_titles);
397                }
398        }
399
400        # strip text after !s provided we have at least one word
401        # e.g. will fix 'Jakers! The Adventures of Piggley Winks' to match 'Jakers'
402        # or 'Jakers! The Adventures of Piggley Winks' to match 'The Adventures of Piggley Winks'
403        foreach my $t (@titles) {
404                if ($t =~ /! /) {
405                        my @t2 = split(/! /,$t);
406                        push(@titles, @t2);
407                }
408        }
409
410        # 'Behind The News (5 Min)' => 'Behind the News 5 Min'
411        #
412        # also used to do:
413        #   'Behind The News (5 Min)' => 'Behind the News'
414        #   'Message Stick (Shorts)' => 'Message Stick'
415        # but removed because it caused false positives on "Stateline (VIC)", "Stateline (TAS)" etc.
416        foreach my $t (@titles) {
417                if ($t =~ /(.+)\((.+)\)$/) {
418                        # my $t2 = $1;
419                        my $t3 = $1.$2;
420                        # $t2 =~ s/(^\s+|\s+$)//g; # strip leading/trailing spaces
421                        $t3 =~ s/(^\s+|\s+$)//g; # strip leading/trailing spaces
422                        # push(@titles,$t2);
423                        push(@titles,$t3);
424                }
425        }
426
427        # 'Family Story: The Longest Season' => 'Family Story'
428        foreach my $t (@titles) {
429                if ($t =~ /: /) {
430                        my @t2 = split(/: /,$t);
431                        push(@titles, @t2);
432                }
433        }
434
435        # removed: causes a false positive on "One World  USA" / "One World  Sri Lanka"
436        # # 'Family Story  The Longest Season' => 'Family Story: The Longest Season'
437        # foreach my $t (@titles) {
438        #       if ($t =~ /  /) {
439        #               my @t2 = split(/  /,$t);
440        #               push(@titles, @t2);
441        #       }
442        # }
443
444        # #39; -> '  ('He&#39;s Having A Baby' => 'He\'s Having a Baby')
445        foreach my $t (@titles) {
446                my $t2 = $t;
447                $t2 =~ s/&(#(\d+)|(.*?));/ $2 ? chr($2) : $amp{$3}||' ' /eg;
448                push(@titles,$t2) if ($t2 ne $t);
449        }
450
451        # 'Head 2 Head' => 'Head To Head'
452        foreach my $t (@titles) {
453                push(@titles, "$1 to $2") if ($t =~ /(.*) 2 (.*)/);
454        }
455
456        # remove leading 'The':
457        # "Iron Chef" alternatives "The Iron Chef"
458        # "The Newshour with Jim Lehrer" alternative "Newshour with Jim Lehrer"
459        foreach my $t (@titles) {
460                push(@titles,"$1") if ($t =~ /^The (.*)$/);
461        }
462
463        # strip "With [..]" if at least 10 chars before With
464        #   "The 7.30 Report With Kerry O'brien" alternatives "The 7.30 Report"
465        #   "Seven News With Peter Mitchell" alternatives "Seven News"
466        #   "Today Tonight With Naomi Robson" alternatives "Today Tonight"
467        foreach my $t (@titles) {
468                if ($t =~/^(.*) [Ww]ith (.*)$/) {
469                        my $t2 = $1;
470                        push (@titles, $t2) if (length($t2) >= 10);
471                }
472        }
473
474        # Place the articles last
475        # 'The Daily Show' => 'Daily Show, The'
476        foreach (@titles) {
477                if ( m/^(The|A|Une|Les|Los|Las|L\'|Le|La|El|Das|De|Het|Een)\s+(.*)$/io ) {
478                        my $t=$_;
479                        $t=~s/^(The|A|Une|Les|Los|Las|L\'|Le|La|El|Das|De|Het|Een)\s+(.*)$/$2, $1/iog;
480                        push(@titles, $t);
481                }
482        }
483
484        #foreach my $t (@titles) { printf "alternativeTitles: alternative \"$t\"\n"; }
485
486        return(@titles);
487}
488
489sub alternativeTitles_match
490{
491        my ($s1,$s2) = @_;
492
493        my @alt1 = alternativeTitles($s1);
494        my @alt2 = alternativeTitles($s2);
495
496        foreach my $a1 (@alt1) {
497                foreach my $a2 (@alt2) {
498                        return 1 if (lc($a1) eq lc($a2));
499                }
500        }
501        return 0;
502}
503
504##############################################################################
505
506sub canonicalizeTitle
507{
508        my $title=shift;
509        $title =~ s/^\s+//;
510        $title =~ s/\s+$//;
511        $title =~ s/\s+/ /;
512        $title =~ s/&(#(\d+)|(.*?));/ $2 ? chr($2) : $amp{$3}||' ' /eg;
513        $title =~ s/ *\& */ and /g;
514        $title =~ s/[^ a-zA-Z0-9]//g;
515        return(lc($title));
516}
517
518my %alternatives = (
519                to  => ("2"),
520                too => ("2"),
521                "2" => ("to", "too")
522                );
523
524sub alternative
525{
526        my $word=shift;
527        return($alternatives{$word});
528}
529
530sub canonicalizeTitles_match
531{
532        my $shorter=canonicalizeTitle(shift);
533        my $longer =canonicalizeTitle(shift);
534
535        if (length($shorter) > length($longer)) {
536                ($shorter,$longer) = ($longer,$shorter);
537        }
538
539#printf "got shorter: '%s', longer '%s'\n",$shorter,$longer;
540WORD:   for my $word (split(/\s/,$shorter)) {
541#printf "got word: '%s'\n",$word;
542                next WORD if ($longer =~ s/\b$word\b//);
543                for my $alt (&alternative($word)) {
544                        next if (!defined $alt);
545                        next WORD if ($longer =~ s/$alt//);
546                }
547                return(0);
548        }
549        return(1);
550}
551
552##############################################################################
Note: See TracBrowser for help on using the browser.