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