View | Details | Raw Unified | Return to bug 7419
Collapse All | Expand All

(-)a/misc/migration_tools/dedup_records.pl (-1 / +478 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
2
3
# Copyright 2013 C & P Bibliography Services
4
#
5
# This file is part of Koha.
6
#
7
# Koha is free software; you can redistribute it and/or modify it under the
8
# terms of the GNU General Public License as published by the Free Software
9
# Foundation; either version 3 of the License, or (at your option) any later
10
# version.
11
#
12
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
15
#
16
# You should have received a copy of the GNU General Public License along
17
# with Koha; if not, write to the Free Software Foundation, Inc.,
18
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20
=head1 NAME
21
22
dedup_records.pl - clean up duplicate records
23
24
=head1 SYNOPSIS
25
26
  dedup_records.pl --match=1 -a
27
28
  dedup_records.pl --match="LC-card-number/010a" --select="date" \
29
    --limit="authid > 367123592" -a
30
31
  dedup_records.pl --match="Match/100abcdefghijklmnopqrstuvwxyz" \
32
    --select="source=DLC" --select="date" --limit="authtypecode='PERSO_NAME'" -a
33
34
=head1 DESCRIPTION
35
36
This script will identify duplicate records, and either suggest that you
37
merge them (in the case of bibliographic records) or automatically merge
38
them for you (in the case of authority records).
39
40
=cut
41
42
use Modern::Perl;
43
use Getopt::Long;
44
use Pod::Usage;
45
use Time::HiRes qw/time/;
46
use POSIX qw/strftime ceil/;
47
48
use C4::Context;
49
use C4::Matcher;
50
use C4::Biblio;
51
use C4::AuthoritiesMarc;
52
53
sub usage {
54
    pod2usage( -verbose => 2 );
55
    exit;
56
}
57
58
=head1 OPTIONS
59
60
=over 8
61
62
=item B<--help>
63
64
Prints this help
65
66
=item B<-v|--verbose>
67
68
Print verbose log information (warning: very verbose!).
69
70
=item B<-t|--test>
71
72
Do not actually make any changes to the database, just report what changes
73
would be made.
74
75
=item B<-r|--report>
76
77
Print a report of what happened during the run.
78
79
=item B<-l|--limit=S>
80
81
Only process those records that match the user-specified WHERE clause
82
(the WHERE is implied and should not be included on the command line).
83
84
=item B<-a|--authorities>
85
86
Check for duplicate authorities rather that duplicate bibliographic records.
87
88
=item B<-s|--select=s>
89
90
Repeatable. Specify how to identify which record to prefer. See the section
91
on SELECTORS below.
92
93
=item B<-m|--match=s>
94
95
Specifies the matching rule to use. This can be the numeric ID of a matching
96
rule that you have already configured (preferred), or you can specify a matching
97
rule on the command-line in the following format:
98
99
    <index1>/<tag1><subfield1>[##<index2>/<tag2><subfield2>[##...]]
100
101
Examples:
102
103
    at/152b##he-main/2..a##he/2..bxyzt##ident/009@
104
    authtype/152b##he-main,ext/2..a##he,ext/2..bxyz
105
    sn,ne,st-numeric/001##authtype/152b##he-main,ext/2..a##he,ext/2..bxyz
106
107
=item B<-c|--check=s>
108
109
Only relevant when you are using a matching rule specified on the command
110
line. Specifies sanity checks to use to ensure that the records are really
111
duplicate. The format is <tag1><subfields1>[,<tag2><subfields2>[,...]]
112
113
Examples:
114
115
    200abxyz will check subfields a,b,x,y,z of 200 fields
116
    009@,152b will check 009 data and 152$b subfields
117
118
=back
119
120
=cut
121
122
my (
123
    $match, $check,  $verbose,     $test_only, $help,
124
    $limit, $report, $authorities, @select
125
);
126
my $max_matches = 50;
127
128
my $result = GetOptions(
129
    'h|help'        => \$help,
130
    'v|verbose'     => \$verbose,
131
    't|test'        => \$test_only,
132
    'r|report'      => \$report,
133
    'l|limit=s'     => \$limit,
134
    'a|authorities' => \$authorities,
135
    's|select=s'    => \@select,
136
    'm|match=s'     => \$match,
137
    'c|check=s'     => \$check,
138
);
139
140
if ( $help || !$match ) {
141
    usage();
142
}
143
144
my $starttime = time();
145
146
my $sql =
147
  $authorities
148
  ? 'SELECT authid FROM auth_header'
149
  : 'SELECT biblionumber FROM biblio';
150
151
if ($limit) {
152
    $sql .= ' WHERE ' . $limit;
153
}
154
155
@select = ('date') unless @select;
156
157
my @selectors = ();
158
159
=head1 SELECTORS
160
161
This script supports a number of selectors for choosing which record
162
is "better."
163
164
=over 8
165
166
=cut
167
168
foreach my $sel (@select) {
169
    for ($sel) {
170
171
=item B<score>
172
173
Prefer the record which is the best match based on the specified matching
174
rule. This will probably only be useful in cases where the matching rule
175
will not match the source record, since the source record will automatically
176
be given a score of 2 * the matching rule threshold if it wasn't picked up
177
by the matcher.
178
179
=cut
180
181
        when (/^score$/) {
182
            push @selectors, sub { return $_[0]->{'score'} || 0 }
183
        }
184
185
=item B<date>
186
187
Prefer the record which is newer based on the 005 field.
188
189
=cut
190
191
        when (/^date$/) {
192
            push @selectors, sub {
193
                return (
194
                    defined $_[0]->{'record'}->field('005')
195
                    ? $_[0]->{'record'}->field('005')->data()
196
                    : 0
197
                );
198
              }
199
        }
200
201
=item B<source=ABC>
202
203
MARC21 only. Prefer records which come from ABC based on the 003 field.
204
205
=cut
206
207
        when (/^source=(.*)$/) {
208
            push @selectors, sub {
209
                return (
210
                    defined $_[0]->{'record'}->field('003')
211
                      && $_[0]->{'record'}->field('003')->data() eq $1
212
                    ? 1
213
                    : 0
214
                );
215
              }
216
        }
217
218
=item B<usage>
219
220
Authorities only. Prefer the record used in the most bibliographic records.
221
222
=cut
223
224
        when (/^usage$/) {
225
            if ($authorities) {
226
                push @selectors, sub {
227
                    return CountUsage( $_[0]->{'record_id'} );
228
                  }
229
            }
230
        }
231
232
=item B<ppn>
233
234
UNIMARC only. Prefer records which have a PPN in the 009 field.
235
236
=cut
237
238
        when (/^ppn$/) {
239
            push @selectors, sub {
240
                return defined $_[0]->{'record'}->field('009')
241
                  && $_[0]->{'record'}->field('009')->data() ? 1 : 0;
242
              }
243
        }
244
    }
245
}
246
247
=back
248
249
=cut
250
251
my $GetRecord;
252
if ($authorities) {
253
    $GetRecord = \&C4::AuthoritiesMarc::GetAuthority;
254
}
255
else {
256
    $GetRecord = \&C4::Biblio::GetBiblio;
257
}
258
259
my $matcher;
260
261
if ( $match =~ m#/# ) {
262
    my @matchers = split( '##', $match );
263
    my $cnt = 0;
264
    $matcher = C4::Matcher->new( $authorities ? 'authority' : 'biblio' );
265
    $matcher->threshold( 1000 * scalar(@matchers) - 1 );
266
    $matcher->code('TEMP');
267
    $matcher->description('Temporary matcher for deduplication run');
268
    while ( $matchers[ $cnt++ ] =~ m#^([^/]+)/([0-9]{3})(.*)$# ) {
269
        $matcher->add_simple_matchpoint( $1, 1000, $2, $3, 0, 0, '' );
270
    }
271
    my @checks = split( ',', $check );
272
    $cnt = 0;
273
    while ( $checks[ $cnt++ ] =~ m#^([0-9]{3})(.*)$# ) {
274
        $matcher->add_simple_required_check( $1, $2, 0, 0, $1, $2, 0, 0, '' );
275
    }
276
}
277
else {
278
    $matcher = C4::Matcher->fetch($match);
279
}
280
281
unless ($matcher) {
282
    die "Unrecognized matcher. Bailing out.\n";
283
}
284
285
print "Retrieving records for checking using query: $sql\n" if $verbose;
286
my $dbh = C4::Context->dbh;
287
my $sth = $dbh->prepare($sql);
288
$sth->execute();
289
290
my %merges     = ();
291
my %rematches  = ();
292
my $counter    = 0;
293
my $checked    = 0;
294
my $bibsmerged = 0;
295
while ( my ($recordid) = $sth->fetchrow_array() ) {
296
    my $record;
297
    $counter++;
298
    print "Checking for matches for record #$counter (id $recordid).\n"
299
      if $verbose;
300
    next if ( $merges{$recordid} );
301
    $checked++;
302
    $record = $GetRecord->($recordid);
303
304
    my @matches = ();
305
    if ( defined $matcher ) {
306
        @matches = $matcher->get_matches( $record, $max_matches );
307
    }
308
    if ( scalar(@matches) > 1 ) {
309
        print "Found matches for $recordid.\n" if $verbose;
310
        my $foundself;
311
        foreach my $rec (@matches) {
312
            $foundself = 1 if $rec->{'record_id'} == $recordid;
313
            $rec->{'record'} = $GetRecord->( $rec->{'record_id'} );
314
            my @weights = ();
315
            foreach my $selector (@selectors) {
316
                push @weights, $selector->($rec);
317
            }
318
            while ( scalar @weights < 5 ) { push @weights, 0; }
319
            $rec->{weights} = \@weights;
320
        }
321
        unless ($foundself) {
322
            my $rec = {
323
                'record_id' => $recordid,
324
                'score'     => $matcher->threshold() * 2,
325
                'record'    => $record
326
            };
327
            my @weights = ();
328
            foreach my $selector (@selectors) {
329
                push @weights, $selector->($rec);
330
            }
331
            while ( scalar @weights < 5 ) { push @weights, 0; }
332
            $rec->{weights} = \@weights;
333
        }
334
        @matches =
335
          sort {
336
                 $b->{'weights'}->[0] <=> $a->{'weights'}->[0]
337
              || $b->{'weights'}->[1] <=> $a->{'weights'}->[1]
338
              || $b->{'weights'}->[2] <=> $a->{'weights'}->[2]
339
              || $b->{'weights'}->[3] <=> $a->{'weights'}->[3]
340
              || $b->{'weights'}->[4] <=> $a->{'weights'}->[4]
341
          } @matches;
342
        print "Identified the following records for merging: "
343
          . join( ', ', map { $_->{'record_id'} } @matches ) . ".\n"
344
          if $verbose;
345
        if (   $merges{ $matches[0]->{'record_id'} }
346
            && $merges{ $matches[0]->{'record_id'} } !=
347
            $matches[0]->{'record_id'} )
348
        {
349
            print
350
"Preferred record $matches[0]->{'record_id'} has already been merged into $merges{$matches[0]->{'record_id'}}.\n"
351
              if $verbose;
352
            $rematches{ $matches[0]->{'record_id'} } =
353
              $merges{ $matches[0]->{'record_id'} };
354
            next;
355
        }
356
        foreach my $ii ( 0 .. $#matches ) {
357
            next if $merges{ $matches[$ii]->{'record_id'} };
358
            $merges{ $matches[$ii]->{'record_id'} } =
359
              $matches[0]->{'record_id'};
360
            if ( $ii > 0 ) {
361
                if ($authorities) {
362
                    print "Merging authority "
363
                      . $matches[$ii]->{'record_id'}
364
                      . " into "
365
                      . $matches[0]->{'record_id'} . ".\n"
366
                      if $verbose;
367
                    if ( !$test_only ) {
368
                        my $editedbibs = merge(
369
                            $matches[$ii]->{'record_id'},
370
                            $matches[$ii]->{'record'},
371
                            $matches[0]->{'record_id'},
372
                            $matches[0]->{'record'}
373
                        );
374
                        print
375
"Changed $editedbibs bibliographic records in the course of merging "
376
                          . $matches[$ii]->{'record_id'}
377
                          . " into "
378
                          . $matches[0]->{'record_id'} . ".\n"
379
                          if $verbose;
380
381
                        $bibsmerged += $editedbibs;
382
                    }
383
                }
384
                else {
385
                    print "Bib "
386
                      . $matches[$ii]->{'record_id'}
387
                      . " should probably be merged into "
388
                      . $matches[0]->{'record_id'} . ".\n";
389
                }
390
            }
391
        }
392
    }
393
}
394
395
$authorities = 'yes' if $authorities;
396
$match = $matcher->code() unless $match =~ m#/#;
397
$check = '(none)' unless $check;
398
my $endtime = time();
399
my $totaltime = ceil( ( $endtime - $starttime ) * 1000 );
400
$starttime = strftime( '%D %T', localtime($starttime) );
401
$endtime   = strftime( '%D %T', localtime($endtime) );
402
403
my @preferred =
404
  map { $_ eq $merges{$_} ? $_ : () } sort { $a <=> $b } keys %merges;
405
my $keepers = scalar(@preferred);
406
my @replaced =
407
  map { $_ ne $merges{$_} ? "$_ => $merges{$_}" : () }
408
  sort { $a <=> $b } keys %merges;
409
my $obsoleted = scalar(@replaced);
410
my @rematched =
411
  map { $_ ne $rematches{$_} ? "$_ (already replaced by $rematches{$_})" : () }
412
  sort { $a <=> $b } keys %rematches;
413
my $needrematch = scalar(@rematched);
414
my $summary     = <<_SUMMARY_;
415
416
Deduplication report
417
=======================================================
418
Match rule:                     $match
419
Check rule:                     $check
420
Selectors:                      @select
421
Run started at:                 $starttime
422
Run ended at:                   $endtime
423
Total run time:                 $totaltime ms
424
Number of records retrieved:    $counter
425
Number of records checked:      $checked
426
Number of records chosen:       $keepers
427
Number of records obsoleted:    $obsoleted
428
Records requiring relink/rerun: $needrematch
429
Bibs merged on authority run:   $bibsmerged
430
_SUMMARY_
431
$summary .= "\n****  Ran in test mode only  ****\n" if $test_only;
432
433
print $summary;
434
435
if ($report) {
436
    if (@preferred) {
437
        print <<_PREFERRED_HEADER_;
438
439
Records identified as preferred
440
-------------------------------------------------------
441
442
_PREFERRED_HEADER_
443
444
        print join( "\n", @preferred ) . "\n\n";
445
    }
446
447
    if (@replaced) {
448
        print <<_REPLACED_HEADER_;
449
450
Records replaced
451
-------------------------------------------------------
452
453
_REPLACED_HEADER_
454
455
        print join( "\n", @replaced ) . "\n\n";
456
    }
457
458
    if (@rematched) {
459
        print <<_REMATCHES_HEADER_;
460
461
Records requiring index update to match
462
-------------------------------------------------------
463
464
_REMATCHES_HEADER_
465
466
        print join( "\n", @rematched ) . "\n\n";
467
468
        print "Please re-run this script after running the linker.\n";
469
    }
470
471
    print $summary;
472
}
473
474
=head1 AUTHOR
475
476
Jared Camins-Esakov <jcamins@cpbibliography.com>
477
478
=cut

Return to bug 7419