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];
  16 while (<FP>) {
  17     my @fields = split "\t", $_;
  18     my $fp = populate_fingerprint(@fields);
  19     rank_fingerprint($fp);
  20 }
  21 dump_records();
  22
  23
  24
  25 sub populate_fingerprint {
  26     my @fields = @_;
  27     my %fp = ();
  28
  29     # populate fp hash
  30     $fp{compact} = shift @fields;
  31     $fp{json}    = shift @fields;
  32     $fp{id}      = shift @fields;
  33
  34     my $stripped = join('', @fields);
  35     $stripped   =~ s/[^A-Za-z0-9]//g;
  36     $fp{sha1}    = sha1_base64($stripped);
  37
  38     # populate records hash
  39     $recs{ $fp{id} }{ $fp{sha1} } = {};
  40
  41     return \%fp;
  42 }
  43
  44
  45 sub rank_fingerprint {
  46     my ($fp) = @_;
  47
  48     my $sha1 = $fp->{sha1};
  49     my $id   = $fp->{id};
  50     my $islead = $recs{$id}{lead};
  51     unless (defined $islead and $islead) {
  52         # only process records which haven't already been set as a sub
  53         unless ($fps{$sha1}) {
  54             # haven't seen this fp before. create a new hashref with the current
  55             # record as lead
  56             $fps{$sha1} = { lead => { id    => $id,
  57                                       score => $fp->{compact} },
  58                             recs => [ $id ] };
  59             $recs{$id}{$sha1}{lead} = 1;
  60         } else {
  61             # have seen this fp. push record id onto matchlist
  62             push @{ $fps{$sha1}{recs} }, $id;
  63             # and set this record as lead if it scores higher than current lead
  64             if ($fp->{compact} > $fps{$sha1}{lead}{score}) {
  65                 $recs{ $fps{$sha1}{lead}{id} }{lead} = 0;
  66                 $recs{ $id }{lead} = 1;
  67                 $fps{$sha1}{lead}{id}    = $id;
  68                 $fps{$sha1}{lead}{score} = $fp->{compact};
  69             }
  70         }
  71     }
  72 }
  73
  74
  75 sub dump_records {
  76     my %used = ();
  77     open OUT, '>', $conf->{output}
  78       or die "Can't open ", $conf->{output}, "$!\n";
  79     for my $id (keys %recs) {
  80         next unless $recs{$id}{lead};
  81         for my $sha1 ( keys %{$recs{$id}} ) {
  82             for my $subid ( @{$fps{$sha1}{recs}} ) {
  83                 next if ($id == $subid);
  84                 next if defined $used{$subid};
  85                 $used{$subid} = 1;
  86                 print OUT "$id\t$subid\n";
  87             }
  88         }
  89     }
  90 }
  91
  92 sub initialize {
  93     my ($c) = @_;
  94     my @missing = ();
  95
  96     # set mode on existing filehandles
  97     binmode(STDIN, ':utf8');
  98
  99     my $rc = GetOptions( $c,
 100                          'output|o=s',
 101                          'help|h',
 102                        );
 103     show_help() unless $rc;
 104     show_help() if ($c->{help});
 105
 106     my @keys = keys %{$c};
 107     show_help() unless (@ARGV and @keys);
 108     for my $key ('output')
 109       { push @missing, $key unless $c->{$key} }
 110     if (@missing) {
 111         print "Required option: ", join(', ', @missing), " missing!\n";
 112         show_help();
 113     }
 114 }
 115
 116 sub show_help {
 117     print <<HELP;
 118 Usage is: compress_fingerprints -o OUTPUTFILE INPUTFILE
 119 HELP
 120 exit;
 121 }