From 79bc5b92dcb70629f9d6894060ae0541db427a15 Mon Sep 17 00:00:00 2001
From: Jared Camins-Esakov <jcamins@cpbibliography.com>
Date: Tue, 4 Jun 2013 23:56:55 -0400
Subject: [PATCH] Bug 7419: General-purpose record deduplicator

This patch adds a script for deduplicating records. It is most useful
for authority records but by design could be easily extended for use
with bibliographic records, if someone had a good use case.

See the follow-up for an updated test plan.

Complete POD documentation:

SYNOPSIS
         dedup_records.pl --match=1 -a

         dedup_records.pl --match="LC-card-number/010a" --select="date" \
           --limit="authid > 367123592" -a

         dedup_records.pl --match="Match/100abcdefghijklmnopqrstuvwxyz" \
           --select="source=DLC" --select="date" \
           --limit="authtypecode='PERSO_NAME'" -a

DESCRIPTION
       This script will identify duplicate records, and either suggest
       that you merge them (in the case of bibliographic records) or
       automatically merge them for you (in the case of authority records).

OPTIONS
       --help  Prints this help

       -v|--verbose
               Print verbose log information (warning: very verbose!).

       -t|--test
               Do not actually make any changes to the database, just
               report what changes would be made.

       -r|--report
               Print a report of what happened during the run.

       -l|--limit=S
               Only process those records that match the user-specified
               WHERE clause (the WHERE is implied and should not be
               included on the command line).

       -a|--authorities
               Check for duplicate authorities rather that duplicate
               bibliographic records.

       -s|--select=s
               Repeatable. Specify how to identify which record to
               prefer. See the section on SELECTORS below.

       -m|--match=s
               Specifies the matching rule to use. This can be the
               numeric ID of a matching rule that you have already
               configured (preferred), or you can specify a matching
               rule on the command-line in the following format:

                   <index1>/<tag1><subfield1>[##<index2>/<tag2><subfield2>[##...]]

               Examples:

                   at/152b##he-main/2..a##he/2..bxyzt##ident/009@
                   authtype/152b##he-main,ext/2..a##he,ext/2..bxyz
                   sn,ne,st-numeric/001##authtype/152b##he-main,ext/2..a##he,ext/2..bxyz

       -c|--check=s
               Only relevant when you are using a matching rule
               specified on the command line. Specifies sanity checks to
               use to ensure that the records are really duplicate. The
               format is <tag1><subfields1>[,<tag2><subfields2>[,...]]

               Examples:

                   200abxyz will check subfields a,b,x,y,z of 200 fields
                   009@,152b will check 009 data and 152$b subfields

SELECTORS
       This script supports a number of selectors for choosing which
       record is "better."

       score   Prefer the record which is the best match based on the
               specified matching rule. This will probably only be
               useful in cases where the matching rule will not match
               the source record, since the source record will
               automatically be given a score of 2 * the matching rule
               threshold if it wasn't picked up by the matcher.

       date    Prefer the record which is newer based on the 005 field.

       source=ABC
               MARC21 only. Prefer records which come from ABC based on
               the 003 field.

       usage   Authorities only. Prefer the record used in the most
               bibliographic records.

       ppn     UNIMARC only. Prefer records which have a PPN in the 009
               field.
---
 misc/migration_tools/dedup_records.pl | 478 ++++++++++++++++++++++++++++++++++
 1 file changed, 478 insertions(+)
 create mode 100755 misc/migration_tools/dedup_records.pl

diff --git a/misc/migration_tools/dedup_records.pl b/misc/migration_tools/dedup_records.pl
new file mode 100755
index 0000000..8639a38
--- /dev/null
+++ b/misc/migration_tools/dedup_records.pl
@@ -0,0 +1,478 @@
+#!/usr/bin/perl
+
+# Copyright 2013 C & P Bibliography Services
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 3 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with Koha; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+=head1 NAME
+
+dedup_records.pl - clean up duplicate records
+
+=head1 SYNOPSIS
+
+  dedup_records.pl --match=1 -a
+
+  dedup_records.pl --match="LC-card-number/010a" --select="date" \
+    --limit="authid > 367123592" -a
+
+  dedup_records.pl --match="Match/100abcdefghijklmnopqrstuvwxyz" \
+    --select="source=DLC" --select="date" --limit="authtypecode='PERSO_NAME'" -a
+
+=head1 DESCRIPTION
+
+This script will identify duplicate records, and either suggest that you
+merge them (in the case of bibliographic records) or automatically merge
+them for you (in the case of authority records).
+
+=cut
+
+use Modern::Perl;
+use Getopt::Long;
+use Pod::Usage;
+use Time::HiRes qw/time/;
+use POSIX qw/strftime ceil/;
+
+use C4::Context;
+use C4::Matcher;
+use C4::Biblio;
+use C4::AuthoritiesMarc;
+
+sub usage {
+    pod2usage( -verbose => 2 );
+    exit;
+}
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<--help>
+
+Prints this help
+
+=item B<-v|--verbose>
+
+Print verbose log information (warning: very verbose!).
+
+=item B<-t|--test>
+
+Do not actually make any changes to the database, just report what changes
+would be made.
+
+=item B<-r|--report>
+
+Print a report of what happened during the run.
+
+=item B<-l|--limit=S>
+
+Only process those records that match the user-specified WHERE clause
+(the WHERE is implied and should not be included on the command line).
+
+=item B<-a|--authorities>
+
+Check for duplicate authorities rather that duplicate bibliographic records.
+
+=item B<-s|--select=s>
+
+Repeatable. Specify how to identify which record to prefer. See the section
+on SELECTORS below.
+
+=item B<-m|--match=s>
+
+Specifies the matching rule to use. This can be the numeric ID of a matching
+rule that you have already configured (preferred), or you can specify a matching
+rule on the command-line in the following format:
+
+    <index1>/<tag1><subfield1>[##<index2>/<tag2><subfield2>[##...]]
+
+Examples:
+
+    at/152b##he-main/2..a##he/2..bxyzt##ident/009@
+    authtype/152b##he-main,ext/2..a##he,ext/2..bxyz
+    sn,ne,st-numeric/001##authtype/152b##he-main,ext/2..a##he,ext/2..bxyz
+
+=item B<-c|--check=s>
+
+Only relevant when you are using a matching rule specified on the command
+line. Specifies sanity checks to use to ensure that the records are really
+duplicate. The format is <tag1><subfields1>[,<tag2><subfields2>[,...]]
+
+Examples:
+
+    200abxyz will check subfields a,b,x,y,z of 200 fields
+    009@,152b will check 009 data and 152$b subfields
+
+=back
+
+=cut
+
+my (
+    $match, $check,  $verbose,     $test_only, $help,
+    $limit, $report, $authorities, @select
+);
+my $max_matches = 50;
+
+my $result = GetOptions(
+    'h|help'        => \$help,
+    'v|verbose'     => \$verbose,
+    't|test'        => \$test_only,
+    'r|report'      => \$report,
+    'l|limit=s'     => \$limit,
+    'a|authorities' => \$authorities,
+    's|select=s'    => \@select,
+    'm|match=s'     => \$match,
+    'c|check=s'     => \$check,
+);
+
+if ( $help || !$match ) {
+    usage();
+}
+
+my $starttime = time();
+
+my $sql =
+  $authorities
+  ? 'SELECT authid FROM auth_header'
+  : 'SELECT biblionumber FROM biblio';
+
+if ($limit) {
+    $sql .= ' WHERE ' . $limit;
+}
+
+@select = ('date') unless @select;
+
+my @selectors = ();
+
+=head1 SELECTORS
+
+This script supports a number of selectors for choosing which record
+is "better."
+
+=over 8
+
+=cut
+
+foreach my $sel (@select) {
+    for ($sel) {
+
+=item B<score>
+
+Prefer the record which is the best match based on the specified matching
+rule. This will probably only be useful in cases where the matching rule
+will not match the source record, since the source record will automatically
+be given a score of 2 * the matching rule threshold if it wasn't picked up
+by the matcher.
+
+=cut
+
+        when (/^score$/) {
+            push @selectors, sub { return $_[0]->{'score'} || 0 }
+        }
+
+=item B<date>
+
+Prefer the record which is newer based on the 005 field.
+
+=cut
+
+        when (/^date$/) {
+            push @selectors, sub {
+                return (
+                    defined $_[0]->{'record'}->field('005')
+                    ? $_[0]->{'record'}->field('005')->data()
+                    : 0
+                );
+              }
+        }
+
+=item B<source=ABC>
+
+MARC21 only. Prefer records which come from ABC based on the 003 field.
+
+=cut
+
+        when (/^source=(.*)$/) {
+            push @selectors, sub {
+                return (
+                    defined $_[0]->{'record'}->field('003')
+                      && $_[0]->{'record'}->field('003')->data() eq $1
+                    ? 1
+                    : 0
+                );
+              }
+        }
+
+=item B<usage>
+
+Authorities only. Prefer the record used in the most bibliographic records.
+
+=cut
+
+        when (/^usage$/) {
+            if ($authorities) {
+                push @selectors, sub {
+                    return CountUsage( $_[0]->{'record_id'} );
+                  }
+            }
+        }
+
+=item B<ppn>
+
+UNIMARC only. Prefer records which have a PPN in the 009 field.
+
+=cut
+
+        when (/^ppn$/) {
+            push @selectors, sub {
+                return defined $_[0]->{'record'}->field('009')
+                  && $_[0]->{'record'}->field('009')->data() ? 1 : 0;
+              }
+        }
+    }
+}
+
+=back
+
+=cut
+
+my $GetRecord;
+if ($authorities) {
+    $GetRecord = \&C4::AuthoritiesMarc::GetAuthority;
+}
+else {
+    $GetRecord = \&C4::Biblio::GetBiblio;
+}
+
+my $matcher;
+
+if ( $match =~ m#/# ) {
+    my @matchers = split( '##', $match );
+    my $cnt = 0;
+    $matcher = C4::Matcher->new( $authorities ? 'authority' : 'biblio' );
+    $matcher->threshold( 1000 * scalar(@matchers) - 1 );
+    $matcher->code('TEMP');
+    $matcher->description('Temporary matcher for deduplication run');
+    while ( $matchers[ $cnt++ ] =~ m#^([^/]+)/([0-9]{3})(.*)$# ) {
+        $matcher->add_simple_matchpoint( $1, 1000, $2, $3, 0, 0, '' );
+    }
+    my @checks = split( ',', $check );
+    $cnt = 0;
+    while ( $checks[ $cnt++ ] =~ m#^([0-9]{3})(.*)$# ) {
+        $matcher->add_simple_required_check( $1, $2, 0, 0, $1, $2, 0, 0, '' );
+    }
+}
+else {
+    $matcher = C4::Matcher->fetch($match);
+}
+
+unless ($matcher) {
+    die "Unrecognized matcher. Bailing out.\n";
+}
+
+print "Retrieving records for checking using query: $sql\n" if $verbose;
+my $dbh = C4::Context->dbh;
+my $sth = $dbh->prepare($sql);
+$sth->execute();
+
+my %merges     = ();
+my %rematches  = ();
+my $counter    = 0;
+my $checked    = 0;
+my $bibsmerged = 0;
+while ( my ($recordid) = $sth->fetchrow_array() ) {
+    my $record;
+    $counter++;
+    print "Checking for matches for record #$counter (id $recordid).\n"
+      if $verbose;
+    next if ( $merges{$recordid} );
+    $checked++;
+    $record = $GetRecord->($recordid);
+
+    my @matches = ();
+    if ( defined $matcher ) {
+        @matches = $matcher->get_matches( $record, $max_matches );
+    }
+    if ( scalar(@matches) > 1 ) {
+        print "Found matches for $recordid.\n" if $verbose;
+        my $foundself;
+        foreach my $rec (@matches) {
+            $foundself = 1 if $rec->{'record_id'} == $recordid;
+            $rec->{'record'} = $GetRecord->( $rec->{'record_id'} );
+            my @weights = ();
+            foreach my $selector (@selectors) {
+                push @weights, $selector->($rec);
+            }
+            while ( scalar @weights < 5 ) { push @weights, 0; }
+            $rec->{weights} = \@weights;
+        }
+        unless ($foundself) {
+            my $rec = {
+                'record_id' => $recordid,
+                'score'     => $matcher->threshold() * 2,
+                'record'    => $record
+            };
+            my @weights = ();
+            foreach my $selector (@selectors) {
+                push @weights, $selector->($rec);
+            }
+            while ( scalar @weights < 5 ) { push @weights, 0; }
+            $rec->{weights} = \@weights;
+        }
+        @matches =
+          sort {
+                 $b->{'weights'}->[0] <=> $a->{'weights'}->[0]
+              || $b->{'weights'}->[1] <=> $a->{'weights'}->[1]
+              || $b->{'weights'}->[2] <=> $a->{'weights'}->[2]
+              || $b->{'weights'}->[3] <=> $a->{'weights'}->[3]
+              || $b->{'weights'}->[4] <=> $a->{'weights'}->[4]
+          } @matches;
+        print "Identified the following records for merging: "
+          . join( ', ', map { $_->{'record_id'} } @matches ) . ".\n"
+          if $verbose;
+        if (   $merges{ $matches[0]->{'record_id'} }
+            && $merges{ $matches[0]->{'record_id'} } !=
+            $matches[0]->{'record_id'} )
+        {
+            print
+"Preferred record $matches[0]->{'record_id'} has already been merged into $merges{$matches[0]->{'record_id'}}.\n"
+              if $verbose;
+            $rematches{ $matches[0]->{'record_id'} } =
+              $merges{ $matches[0]->{'record_id'} };
+            next;
+        }
+        foreach my $ii ( 0 .. $#matches ) {
+            next if $merges{ $matches[$ii]->{'record_id'} };
+            $merges{ $matches[$ii]->{'record_id'} } =
+              $matches[0]->{'record_id'};
+            if ( $ii > 0 ) {
+                if ($authorities) {
+                    print "Merging authority "
+                      . $matches[$ii]->{'record_id'}
+                      . " into "
+                      . $matches[0]->{'record_id'} . ".\n"
+                      if $verbose;
+                    if ( !$test_only ) {
+                        my $editedbibs = merge(
+                            $matches[$ii]->{'record_id'},
+                            $matches[$ii]->{'record'},
+                            $matches[0]->{'record_id'},
+                            $matches[0]->{'record'}
+                        );
+                        print
+"Changed $editedbibs bibliographic records in the course of merging "
+                          . $matches[$ii]->{'record_id'}
+                          . " into "
+                          . $matches[0]->{'record_id'} . ".\n"
+                          if $verbose;
+
+                        $bibsmerged += $editedbibs;
+                    }
+                }
+                else {
+                    print "Bib "
+                      . $matches[$ii]->{'record_id'}
+                      . " should probably be merged into "
+                      . $matches[0]->{'record_id'} . ".\n";
+                }
+            }
+        }
+    }
+}
+
+$authorities = 'yes' if $authorities;
+$match = $matcher->code() unless $match =~ m#/#;
+$check = '(none)' unless $check;
+my $endtime = time();
+my $totaltime = ceil( ( $endtime - $starttime ) * 1000 );
+$starttime = strftime( '%D %T', localtime($starttime) );
+$endtime   = strftime( '%D %T', localtime($endtime) );
+
+my @preferred =
+  map { $_ eq $merges{$_} ? $_ : () } sort { $a <=> $b } keys %merges;
+my $keepers = scalar(@preferred);
+my @replaced =
+  map { $_ ne $merges{$_} ? "$_ => $merges{$_}" : () }
+  sort { $a <=> $b } keys %merges;
+my $obsoleted = scalar(@replaced);
+my @rematched =
+  map { $_ ne $rematches{$_} ? "$_ (already replaced by $rematches{$_})" : () }
+  sort { $a <=> $b } keys %rematches;
+my $needrematch = scalar(@rematched);
+my $summary     = <<_SUMMARY_;
+
+Deduplication report
+=======================================================
+Match rule:                     $match
+Check rule:                     $check
+Selectors:                      @select
+Run started at:                 $starttime
+Run ended at:                   $endtime
+Total run time:                 $totaltime ms
+Number of records retrieved:    $counter
+Number of records checked:      $checked
+Number of records chosen:       $keepers
+Number of records obsoleted:    $obsoleted
+Records requiring relink/rerun: $needrematch
+Bibs merged on authority run:   $bibsmerged
+_SUMMARY_
+$summary .= "\n****  Ran in test mode only  ****\n" if $test_only;
+
+print $summary;
+
+if ($report) {
+    if (@preferred) {
+        print <<_PREFERRED_HEADER_;
+
+Records identified as preferred
+-------------------------------------------------------
+
+_PREFERRED_HEADER_
+
+        print join( "\n", @preferred ) . "\n\n";
+    }
+
+    if (@replaced) {
+        print <<_REPLACED_HEADER_;
+
+Records replaced
+-------------------------------------------------------
+
+_REPLACED_HEADER_
+
+        print join( "\n", @replaced ) . "\n\n";
+    }
+
+    if (@rematched) {
+        print <<_REMATCHES_HEADER_;
+
+Records requiring index update to match
+-------------------------------------------------------
+
+_REMATCHES_HEADER_
+
+        print join( "\n", @rematched ) . "\n\n";
+
+        print "Please re-run this script after running the linker.\n";
+    }
+
+    print $summary;
+}
+
+=head1 AUTHOR
+
+Jared Camins-Esakov <jcamins@cpbibliography.com>
+
+=cut
-- 
1.9.1