match_fingerprints

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use open ':utf8';
   5
   6 use Digest::SHA1 qw(sha1_base64);
   7 use Getopt::Long;
   8
   9 my $conf  = {}; # configuration hashref
  10 initialize($conf);
  11
  12 my %fps  = (); # records matching each fingerprint (and the lead)
  13 my @recs = (); # fingerprints belonging to each record
  14 my %seen = (); # records we've already seen
  15 my $lastscore = 0; # previous fingerprint's score
  16
  17 my %subs  = (); # error-checking hashe
  18
  19 open FP, '<', $ARGV[0] or die "Can't open input file: $!\n";
  20
  21 print "Loading and ranking fingerprints\n";
  22 while (<FP>) {
  23     my @fields = split "\t", $_;
  24     my $fp = populate_fingerprint(@fields);
  25     rank_fingerprint($fp);
  26 }
  27 print "Writing matchset to disk\n";
  28 dump_records();
  29
  30
  31
  32 sub populate_fingerprint {
  33     my @fields = @_;
  34     my %fp = (); # zero fingerprint hash each time thru
  35
  36     # populate fp hash -- first the simple data
  37     $fp{compact} = shift @fields;
  38     $fp{json}    = shift @fields;
  39     $fp{id}      = shift @fields;
  40     # then smash everything else together, remove non-Roman characters, and
  41     # generate a SHA1 hash to represent it
  42     my $stripped = join('', @fields);
  43     $stripped   =~ s/[^A-Za-z0-9]//g;
  44     $fp{sha1}    = sha1_base64($stripped);
  45
  46     # make sure file is sorted properly
  47     if ($lastscore and ($fp{compact} > $lastscore)) {
  48         print "Input file is sorted improperly or unsorted.\n";
  49         die "Sort descending (sort -r) and rerun this script.\n";
  50     }
  51     $lastscore = $fp{compact};
  52
  53     return \%fp;
  54 }
  55
  56
  57 sub rank_fingerprint {
  58     my ($fp) = @_;
  59
  60     my $sha1 = $fp->{sha1};
  61     my $id   = $fp->{id};
  62
  63     # only process records which haven't already been seen
  64     unless (defined $seen{$id}) {
  65         unless (defined $fps{$sha1}) {
  66             # haven't seen this fp before. create a new listref to hold subs
  67             # and stow the hash of the fingerprint that we're lead of
  68             $fps{$sha1} = [];
  69             push @recs, {id => $id, sha1 => $sha1};
  70         } else {
  71             # have seen this fp. push record id onto matchlist
  72             push @{ $fps{$sha1} }, $id;
  73         }
  74         $seen{$id} = 1;
  75     }
  76 }
  77
  78
  79 =head2 dump_records
  80
  81 Writes out a 2-column file of lead and subordinate records.
  82
  83 =cut
  84
  85 sub dump_records {
  86     my %used = ();
  87     open OUT, '>', $conf->{output}
  88       or die "Can't open ", $conf->{output}, "$!\n";
  89     for my $rec (@recs) {
  90         for ( @{ $fps{ $rec->{sha1} } } ) {
  91             # check for dupes and die if they exist
  92             die "Collision: dupe sub record $_\n" if $subs{$_};
  93             $subs{$_} = 1;
  94             die "Collision: lead in sub list ", $rec->{id}, "\n"
  95               if $subs{ $rec->{id} };
  96
  97             # still here? output.
  98             print OUT $rec->{id}, "\t$_\n"
  99         }
 100     }
 101 }
 102
 103 sub initialize {
 104     my ($c) = @_;
 105     my @missing = ();
 106
 107     # set mode on existing filehandles
 108     binmode(STDIN, ':utf8');
 109
 110     my $rc = GetOptions( $c,
 111                          'output|o=s',
 112                          'help|h',
 113                        );
 114     show_help() unless $rc;
 115     show_help() if ($c->{help});
 116
 117     my @keys = keys %{$c};
 118     show_help() unless (@ARGV and @keys);
 119     for my $key ('output')
 120       { push @missing, $key unless $c->{$key} }
 121     if (@missing) {
 122         print "Required option: ", join(', ', @missing), " missing!\n";
 123         show_help();
 124     }
 125 }
 126
 127 sub show_help {
 128     print <<HELP;
 129 Usage is: compress_fingerprints -o OUTPUTFILE INPUTFILE
 130 HELP
 131 exit;
 132 }