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