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 my $lastscore = 0; # previous fingerprint's score
  15
  16 open FP, '<', $ARGV[0] or die "Can't open input file: $!\n";
  17
  18 print "Loading and ranking fingerprints\n";
  19 while (<FP>) {
  20     my @fields = split "\t", $_;
  21     my $fp = populate_fingerprint(@fields);
  22     rank_fingerprint($fp);
  23     print "\r", ( int($i / $total) ), "% complete" unless ($i % 1000);
  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 -ru) and rerun this script.\n";
  48     }
  49     $lastscore = $fp{compact};
  50
  51     # populate records hash
  52     $recs{ $fp{id} }{ $fp{sha1} } = {};
  53
  54     return \%fp;
  55 }
  56
  57
  58 sub rank_fingerprint {
  59     my ($fp) = @_;
  60
  61     my $sha1 = $fp->{sha1};
  62     my $id   = $fp->{id};
  63     my $islead = $recs{$id}{lead};
  64
  65     # only process records which haven't already been set as a sub
  66     unless (defined $islead and $islead) {
  67         unless ($fps{$sha1}) {
  68             # haven't seen this fp before. create a new hashref with the current
  69             # record as lead
  70             $fps{$sha1} = { lead => { id    => $id,
  71                                       score => $fp->{compact} },
  72                             recs => [ $id ] };
  73             $recs{$id}{lead} = 1;
  74         } else {
  75             # have seen this fp. push record id onto matchlist
  76             push @{ $fps{$sha1}{recs} }, $id;
  77             if ($fp->{compact} > $fps{$sha1}{lead}{score}) {
  78                 # and set this record as lead if it scores higher than current lead
  79                 $recs{ $fps{$sha1}{lead}{id} }{lead} = 0; # unset current
  80                 $recs{ $id }{lead} = 1;                   # set new as lead
  81                 $fps{$sha1}{lead}{id}    = $id;
  82                 $fps{$sha1}{lead}{score} = $fp->{compact};
  83             }
  84         }
  85     }
  86 }
  87
  88
  89 =head2 dump_records
  90
  91 Writes out a 2-column file of lead and subordinate records. If
  92 posttest is enabled, a scan is also done to ensure that no recordid
  93 appears as both a subordinate and lead.
  94
  95 =cut
  96
  97 sub dump_records {
  98     my %used = ();
  99     open OUT, '>', $conf->{output}
 100       or die "Can't open ", $conf->{output}, "$!\n";
 101     for my $id (keys %recs) {
 102         next unless $recs{$id}{lead};
 103         for my $sha1 ( keys %{$recs{$id}} ) {
 104             for my $subid ( @{$fps{$sha1}{recs}} ) {
 105                 next if ($id == $subid);
 106                 next if defined $used{$subid};
 107                 $used{$subid} = 1;
 108                 print OUT "$id\t$subid\n";
 109             }
 110         }
 111     }
 112 }
 113
 114 sub initialize {
 115     my ($c) = @_;
 116     my @missing = ();
 117
 118     # set mode on existing filehandles
 119     binmode(STDIN, ':utf8');
 120
 121     my $rc = GetOptions( $c,
 122                          'output|o=s',
 123                          'help|h',
 124                        );
 125     show_help() unless $rc;
 126     show_help() if ($c->{help});
 127
 128     my @keys = keys %{$c};
 129     show_help() unless (@ARGV and @keys);
 130     for my $key ('output')
 131       { push @missing, $key unless $c->{$key} }
 132     if (@missing) {
 133         print "Required option: ", join(', ', @missing), " missing!\n";
 134         show_help();
 135     }
 136 }
 137
 138 sub show_help {
 139     print <<HELP;
 140 Usage is: compress_fingerprints -o OUTPUTFILE INPUTFILE
 141 HELP
 142 exit;
 143 }