match_fingerprints

   1 #!/usr/bin/perl
   2
   3 # Copyright 2009-2012, Equinox Software, Inc.
   4 #
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  18
  19
  20 use strict;
  21 use warnings;
  22 use open ':utf8';
  23
  24 use Digest::SHA1 qw(sha1_base64);
  25 use Getopt::Long;
  26
  27 my $conf  = {}; # configuration hashref
  28 initialize($conf);
  29
  30 my %fps  = (); # records matching each fingerprint (and the lead)
  31 my @recs = (); # fingerprints belonging to each record
  32 my %seen = (); # records we've already seen
  33 my $lastscore = 0; # previous fingerprint's score
  34
  35 my %subs  = (); # error-checking hashe
  36
  37 open FP, '<', $ARGV[0] or die "Can't open input file: $!\n";
  38
  39 print "Loading and ranking fingerprints\n";
  40 while (<FP>) {
  41     my @fields = split "\t", $_;
  42     my $fp = populate_fingerprint(@fields);
  43     rank_fingerprint($fp);
  44 }
  45 print "Writing matchset to disk\n";
  46 dump_records();
  47
  48
  49
  50 sub populate_fingerprint {
  51     my @fields = @_;
  52     my %fp = (); # zero fingerprint hash each time thru
  53
  54     # populate fp hash -- first the simple data
  55     $fp{compact} = shift @fields;
  56     $fp{json}    = shift @fields;
  57     $fp{id}      = shift @fields;
  58     # then smash everything else together, remove non-Roman characters, and
  59     # generate a SHA1 hash to represent it
  60     my $stripped = join('', @fields);
  61     $stripped   =~ s/[^A-Za-z0-9]//g;
  62     $fp{sha1}    = sha1_base64($stripped);
  63
  64     # make sure file is sorted properly
  65     if ($lastscore and ($fp{compact} > $lastscore)) {
  66         print "Input file is sorted improperly or unsorted.\n";
  67         die "Sort descending (sort -r) and rerun this script.\n";
  68     }
  69     $lastscore = $fp{compact};
  70
  71     return \%fp;
  72 }
  73
  74
  75 sub rank_fingerprint {
  76     my ($fp) = @_;
  77
  78     my $sha1 = $fp->{sha1};
  79     my $id   = $fp->{id};
  80
  81     # only process records which haven't already been seen
  82     unless (defined $seen{$id}) {
  83         unless (defined $fps{$sha1}) {
  84             # haven't seen this fp before. create a new listref to hold subs
  85             # and stow the hash of the fingerprint that we're lead of
  86             $fps{$sha1} = [];
  87             push @recs, {id => $id, sha1 => $sha1};
  88         } else {
  89             # have seen this fp. push record id onto matchlist
  90             push @{ $fps{$sha1} }, $id;
  91         }
  92         $seen{$id} = 1;
  93     }
  94 }
  95
  96
  97 =head2 dump_records
  98
  99 Writes out a 2-column file of lead and subordinate records.
 100
 101 =cut
 102
 103 sub dump_records {
 104     my %used = ();
 105     open OUT, '>', $conf->{output}
 106       or die "Can't open ", $conf->{output}, "$!\n";
 107     for my $rec (@recs) {
 108         for ( @{ $fps{ $rec->{sha1} } } ) {
 109             # check for dupes and die if they exist
 110             die "Collision: dupe sub record $_\n" if $subs{$_};
 111             $subs{$_} = 1;
 112             die "Collision: lead in sub list ", $rec->{id}, "\n"
 113               if $subs{ $rec->{id} };
 114
 115             # we don't want subs below threshold
 116             next if ($_ < $conf->{threshold});
 117
 118             # still here? output.
 119             print OUT $rec->{id}, "\t$_\n"
 120         }
 121     }
 122 }
 123
 124 sub initialize {
 125     my ($c) = @_;
 126     my @missing = ();
 127
 128     # set mode on existing filehandles
 129     binmode(STDIN, ':utf8');
 130
 131     my $rc = GetOptions( $c,
 132                          'output|o=s',
 133                          'threshold|t=i',
 134                          'help|h',
 135                        );
 136     show_help() unless $rc;
 137     show_help() if ($c->{help});
 138
 139     my @keys = keys %{$c};
 140     show_help() unless (@ARGV and @keys);
 141     for my $key ('output')
 142       { push @missing, $key unless $c->{$key} }
 143     if (@missing) {
 144         print "Required option: ", join(', ', @missing), " missing!\n";
 145         show_help();
 146     }
 147
 148     $c->{threshold} = 0 unless $c->{threshold};
 149 }
 150
 151 sub show_help {
 152     print <<HELP;
 153 Usage is: compress_fingerprints [-t THRESHOLD] -o OUTPUTFILE INPUTFILE
 154 HELP
 155 exit;
 156 }