source: main/trunk/greenstone2/perllib/classify/List.pm@ 24193

Last change on this file since 24193 was 24193, checked in by ak19, 10 years ago

Non-English characters in the user-entered buttonname of all classifiers need to be preserved. BaseClassifier now does this, for which it has to assume that the user-entered buttonname is in UTF-8

  • Property svn:keywords set to Author Date Id Revision
File size: 36.0 KB
Line 
1###########################################################################
2#
3# List.pm -- A general and flexible list classifier with most of
4# the abilities of AZCompactList, and better Unicode,
5# metadata and sorting capabilities.
6#
7# A component of the Greenstone digital library software
8# from the New Zealand Digital Library Project at the
9# University of Waikato, New Zealand.
10#
11# Author: Michael Dewsnip, NZDL Project, University of Waikato, NZ
12#
13# Copyright (C) 2005 New Zealand Digital Library Project
14#
15# This program is free software; you can redistribute it and/or modify
16# it under the terms of the GNU General Public License as published by
17# the Free Software Foundation; either version 2 of the License, or
18# (at your option) any later version.
19#
20# This program is distributed in the hope that it will be useful,
21# but WITHOUT ANY WARRANTY; without even the implied warranty of
22# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23# GNU General Public License for more details.
24#
25# You should have received a copy of the GNU General Public License
26# along with this program; if not, write to the Free Software
27# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
28#
29# TO DO: - Remove punctuation from metadata values before sorting.
30# - Add an AZCompactList-style hlist option?
31#
32###########################################################################
33
34package List;
35
36
37use BaseClassifier;
38
39use strict;
40
41
42sub BEGIN {
43 @List::ISA = ('BaseClassifier');
44}
45
46my $partition_type_list =
47 [ { 'name' => "per_letter",
48 'desc' => "{List.level_partition.per_letter}" },
49 { 'name' => "approximate_size",
50 'desc' => "{List.level_partition.approximate_size}"},
51 { 'name' => "constant_size",
52 'desc' => "{List.level_partition.constant_size}" },
53 { 'name' => "none",
54 'desc' => "{List.level_partition.none}" } ];
55
56# following used to check types later on
57my $valid_partition_types = { 'per_letter' => 1,
58 'constant_size' => 1,
59 'per_letter_fixed_size' => 1,
60 'approximate_size' => 1,
61 'none' => 1};
62
63my $bookshelf_type_list =
64 [ { 'name' => "always",
65 'desc' => "{List.bookshelf_type.always}" },
66 { 'name' => "duplicate_only",
67 'desc' => "{List.bookshelf_type.duplicate_only}" },
68 { 'name' => "never",
69 'desc' => "{List.bookshelf_type.never}" } ];
70
71my $arguments =
72 [ { 'name' => "metadata",
73 'desc' => "{List.metadata}",
74 'type' => "metadata",
75 'reqd' => "yes" },
76
77 # The interesting options
78 { 'name' => "bookshelf_type",
79 'desc' => "{List.bookshelf_type}",
80 'type' => "enum",
81 'list' => $bookshelf_type_list,
82 'deft' => "never" },
83 { 'name' => "classify_sections",
84 'desc' => "{List.classify_sections}",
85 'type' => "flag" },
86 { 'name' => "partition_type_within_level",
87 'desc' => "{List.partition_type_within_level}",
88 'type' => "enumstring", # Must be enumstring because multiple values can be specified (separated by '/')
89 'list' => $partition_type_list,
90 'deft' => "per_letter" },
91 { 'name' => "partition_size_within_level",
92 'desc' => "{List.partition_size_within_level}",
93 'type' => "string" }, # Must be string because multiple values can be specified (separated by '/')
94 { 'name' => "partition_name_length",
95 'desc' => "{List.partition_name_length}",
96 'type' => "string" },
97 { 'name' => "sort_leaf_nodes_using",
98 'desc' => "{List.sort_leaf_nodes_using}",
99 'type' => "metadata",
100 'deft' => "Title" },
101 { 'name' => "reverse_sort_leaf_nodes",
102 'desc' => "{List.reverse_sort_leaf_nodes}",
103 'type' => "flag"},
104 { 'name' => "sort_using_unicode_collation",
105 'desc' => "{List.sort_using_unicode_collation}",
106 'type' => "flag" },
107 { 'name' => "use_hlist_for",
108 'desc' => "{List.use_hlist_for}",
109 'type' => "string" },
110 { 'name' => "removeprefix",
111 'desc' => "{BasClas.removeprefix}",
112 'type' => "regexp" },
113 { 'name' => "removesuffix",
114 'desc' => "{BasClas.removesuffix}",
115 'type' => "regexp" } ];
116
117my $options = { 'name' => "List",
118 'desc' => "{List.desc}",
119 'abstract' => "no",
120 'inherits' => "yes",
121 'args' => $arguments };
122
123
124sub new
125{
126 my ($class) = shift(@_);
127 my ($classifierslist, $inputargs, $hashArgOptLists) = @_;
128 push(@$classifierslist, $class);
129
130 push(@{$hashArgOptLists->{"ArgList"}}, @{$arguments});
131 push(@{$hashArgOptLists->{"OptList"}}, $options);
132
133 my $self = new BaseClassifier($classifierslist, $inputargs, $hashArgOptLists);
134
135 if ($self->{'info_only'}) {
136 # don't worry about any options etc
137 return bless $self, $class;
138 }
139
140 # The metadata elements to use (required)
141 if (!$self->{'metadata'}) {
142 die "Error: No metadata fields specified for List.\n";
143 }
144
145 my @metadata_groups = split(/[\/]/, $self->{'metadata'});
146 $self->{'metadata_groups'} = \@metadata_groups;
147
148 # The classifier button name (default: the first metadata element specified)
149 if (!$self->{'buttonname'}) {
150 my $first_metadata_group = $metadata_groups[0];
151 my $first_metadata_element = (split(/[\;|,\/]/, $first_metadata_group))[0];
152 $self->{'buttonname'} = $self->generate_title_from_metadata($first_metadata_element);
153 }
154
155 # Whether to group items into a bookshelf, (must be 'always' for all metadata fields except the last)
156 foreach my $metadata_group (@metadata_groups) {
157 $self->{$metadata_group . ".bookshelf_type"} = "always";
158 }
159 my $last_metadata_group = $metadata_groups[$#metadata_groups];
160 # Default: duplicate_only, ie. leave leaf nodes ungrouped (equivalent to AZCompactList -mingroup 2)
161 $self->{$last_metadata_group . ".bookshelf_type"} = $self->{'bookshelf_type'};
162
163 # Whether to use an hlist or a vlist for each level in the hierarchy (default: vlist)
164 foreach my $metadata_group (@metadata_groups) {
165 $self->{$metadata_group . ".list_type"} = "VList";
166 }
167 foreach my $metadata_group (split(/\,/, $self->{'use_hlist_for'})) {
168 $self->{$metadata_group . ".list_type"} = "HList";
169 }
170
171 # How the items are grouped into partitions (default: no partition)
172 # for each level (metadata group), separated by '/'
173 if (!$self->{"partition_type_within_level"}) {
174 foreach my $metadata_group (@metadata_groups) {
175 $self->{$metadata_group . ".partition_type_within_level"} = "none";
176 }
177 } else {
178 my @partition_type_within_levellist = split(/\//, $self->{'partition_type_within_level'});
179
180 my $first = 1;
181 foreach my $metadata_group (@metadata_groups) {
182 my $partition_type_within_levelelem = shift(@partition_type_within_levellist);
183 if (defined($partition_type_within_levelelem) && $partition_type_within_levelelem eq "per_letter_fixed_size") {
184 print STDERR "per letter fixed size, changing to approximate size\n";
185 $partition_type_within_levelelem = "approximate_size";
186 }
187 if (defined($partition_type_within_levelelem) && defined $valid_partition_types->{$partition_type_within_levelelem}) {
188 $self->{$metadata_group . ".partition_type_within_level"} = $partition_type_within_levelelem;
189 }
190 else {
191 if ($first) {
192 $self->{$metadata_group . ".partition_type_within_level"} = "none";
193 $first = 0;
194 } else {
195 $self->{$metadata_group . ".partition_type_within_level"} = $self->{$metadata_groups[0] . ".partition_type_within_level"};
196 }
197 if (defined($partition_type_within_levelelem)) {
198 # ie invalid entry
199 print STDERR "invalid partition type for level $metadata_group: $partition_type_within_levelelem, defaulting to ". $self->{$metadata_group . ".partition_type_within_level"} ."\n";
200 }
201 }
202 }
203 }
204
205 # The number of items in each partition
206 if (!$self->{'partition_size_within_level'}) {
207 # Default: 20
208 foreach my $metadata_group (@metadata_groups) {
209 $self->{$metadata_group . ".partition_size_within_level"} = 20;
210 }
211 }
212 else {
213 my @partition_size_within_levellist = split(/\//, $self->{'partition_size_within_level'});
214
215 # Assign values based on the partition_size_within_level parameter
216 foreach my $metadata_group (@metadata_groups) {
217 my $partition_size_within_levelelem = shift(@partition_size_within_levellist);
218 if (defined($partition_size_within_levelelem)) {
219 $self->{$metadata_group . ".partition_size_within_level"} = $partition_size_within_levelelem;
220 }
221 else {
222 $self->{$metadata_group . ".partition_size_within_level"} = $self->{$metadata_groups[0] . ".partition_size_within_level"};
223 }
224 }
225 }
226
227 # The removeprefix and removesuffix expressions
228 if ($self->{'removeprefix'}) {
229 # If there are more than one expressions, use '' to quote each experession and '/' to separate
230 my @removeprefix_exprs_within_levellist = split(/'\/'/, $self->{'removeprefix'});
231
232 foreach my $metadata_group (@metadata_groups) {
233 my $removeprefix_expr_within_levelelem = shift(@removeprefix_exprs_within_levellist);
234 if (defined($removeprefix_expr_within_levelelem) && $removeprefix_expr_within_levelelem ne "") {
235 # Remove the other ' at the beginning and the end if there is any
236 $removeprefix_expr_within_levelelem =~ s/^'//;
237 $removeprefix_expr_within_levelelem =~ s/'$//;
238 # Remove the extra ^ at the beginning
239 $removeprefix_expr_within_levelelem =~ s/^\^//;
240 $self->{$metadata_group . ".remove_prefix_expr"} = $removeprefix_expr_within_levelelem;
241 } else {
242 $self->{$metadata_group . ".remove_prefix_expr"} = $self->{$metadata_groups[0] . ".remove_prefix_expr"};
243 }
244 }
245 }
246 if ($self->{'removesuffix'}) {
247 my @removesuffix_exprs_within_levellist = split(/'\/'/, $self->{'removesuffix'});
248
249 foreach my $metadata_group (@metadata_groups) {
250 my $removesuffix_expr_within_levelelem = shift(@removesuffix_exprs_within_levellist);
251 if (defined($removesuffix_expr_within_levelelem) && $removesuffix_expr_within_levelelem ne "") {
252 $removesuffix_expr_within_levelelem =~ s/^'//;
253 $removesuffix_expr_within_levelelem =~ s/'$//;
254 # Remove the extra $ at the end
255 $removesuffix_expr_within_levelelem =~ s/\$$//;
256 $self->{$metadata_group . ".remove_suffix_expr"} = $removesuffix_expr_within_levelelem;
257 } else {
258 $self->{$metadata_group . ".remove_suffix_expr"} = $self->{$metadata_groups[0] . ".remove_suffix_expr"};
259 }
260 }
261 }
262
263 # The metadata elements to use to sort the leaf nodes (default: Title)
264 my @sort_leaf_nodes_using_metadata_groups = ( "Title" );
265 if ($self->{'sort_leaf_nodes_using'}) {
266 @sort_leaf_nodes_using_metadata_groups = split(/\|/, $self->{'sort_leaf_nodes_using'});
267 }
268 $self->{'sort_leaf_nodes_using_metadata_groups'} = \@sort_leaf_nodes_using_metadata_groups;
269
270 # Create an instance of the Unicode::Collate object if better Unicode sorting is desired
271 if ($self->{'sort_using_unicode_collation'}) {
272 # To use this you first need to download the allkeys.txt file from
273 # http://www.unicode.org/Public/UCA/latest/allkeys.txt and put it in the Perl
274 # Unicode/Collate directory.
275 require Unicode::Collate;
276 $self->{'unicode_collator'} = Unicode::Collate->new();
277 }
278
279 # An empty array for the document/section OIDs that we are classifying
280 $self->{'OIDs'} = [];
281 # A hash for all the doc ids that we have seen, so we don't classify something twice
282 $self->{'all_doc_OIDs'} = {};
283 return bless $self, $class;
284}
285
286
287sub init
288{
289 # Nothing to do...
290}
291
292
293# Called for each document in the collection
294sub classify
295{
296 my $self = shift(@_);
297 my ($doc_obj) = @_;
298
299 if (defined $self->{'all_doc_OIDs'}->{$doc_obj->get_OID()}) {
300 print STDERR "Warning, List classifier has already seen document ".$doc_obj->get_OID().", not classifying again\n";
301 return;
302 }
303 $self->{'all_doc_OIDs'}->{$doc_obj->get_OID()} = 1;
304 # If "-classify_sections" is set, classify every section of the document
305 if ($self->{'classify_sections'}) {
306 my $section = $doc_obj->get_next_section($doc_obj->get_top_section());
307 while (defined $section) {
308 $self->classify_section($doc_obj, $doc_obj->get_OID() . ".$section", $section);
309 $section = $doc_obj->get_next_section($section);
310 }
311 }
312 # Otherwise just classify the top document section
313 else {
314 $self->classify_section($doc_obj, $doc_obj->get_OID(), $doc_obj->get_top_section());
315 }
316
317}
318
319sub classify_section
320{
321 my $self = shift(@_);
322 my ($doc_obj,$section_OID,$section) = @_;
323
324 my @metadata_groups = @{$self->{'metadata_groups'}};
325
326 # Only classify the section if it has a value for one of the metadata elements in the first group
327 my $classify_section = 0;
328 my $first_metadata_group = $metadata_groups[0];
329 my $remove_prefix_expr = $self->{$first_metadata_group . ".remove_prefix_expr"};
330 my $remove_suffix_expr = $self->{$first_metadata_group . ".remove_suffix_expr"};
331 foreach my $first_metadata_group_element (split(/\;|,/, $first_metadata_group)) {
332 my $real_first_metadata_group_element = $self->strip_ex_from_metadata($first_metadata_group_element);
333 my $first_metadata_group_element_value = $doc_obj->get_metadata_element($section, $real_first_metadata_group_element);
334
335 # Remove prefix/suffix if requested
336 if (defined ($first_metadata_group_element_value)) {
337 if (defined $remove_prefix_expr && $remove_prefix_expr ne "") {
338 $first_metadata_group_element_value =~ s/^$remove_prefix_expr//;
339 }
340
341 if (defined $remove_suffix_expr && $remove_suffix_expr ne "") {
342 $first_metadata_group_element_value =~ s/$remove_suffix_expr$//;
343 }
344 }
345 if (defined($first_metadata_group_element_value) && $first_metadata_group_element_value ne "") {
346 # This section must be included in the classifier
347 $classify_section = 1;
348 last;
349 }
350 }
351
352 # We're not classifying this section because it doesn't have the required metadata
353 return if (!$classify_section);
354
355 # Otherwise, include this section in the classifier
356
357 push(@{$self->{'OIDs'}}, $section_OID);
358
359 # Create a hash for the metadata values of each metadata element we're interested in
360 my %metadata_groups_done = ();
361 foreach my $metadata_group (@metadata_groups, @{$self->{'sort_leaf_nodes_using_metadata_groups'}}) {
362 # Take care not to do a metadata group more than once
363 unless ($metadata_groups_done{$metadata_group}) {
364 my $remove_prefix_expr = $self->{$metadata_group . ".remove_prefix_expr"};
365 my $remove_suffix_expr = $self->{$metadata_group . ".remove_suffix_expr"};
366 foreach my $metadata_element (split(/\;|,/, $metadata_group)) {
367 my $real_metadata_element = $self->strip_ex_from_metadata($metadata_element);
368
369 my @metadata_values = @{$doc_obj->get_metadata($section, $real_metadata_element)};
370 foreach my $metadata_value (@metadata_values) {
371 # Strip leading and trailing whitespace
372 $metadata_value =~ s/^\s*//;
373 $metadata_value =~ s/\s*$//;
374
375 # Remove prefix/suffix if requested
376 if (defined $remove_prefix_expr && $remove_prefix_expr ne "") {
377 $metadata_value =~ s/^$remove_prefix_expr//;
378 }
379 if (defined $remove_suffix_expr && $remove_suffix_expr ne "") {
380 $metadata_value =~ s/$remove_suffix_expr$//;
381 }
382
383 # Don't uppercase metadata here, user can change the display with CSS or javascript
384 # further on. Moreover, CSS is unable to turn letters that are capitals by default
385 # into lowercase, whereas letters that are lowercase by default can be titlecased or
386 # capitalised later with CSS if necessary.
387 # uppercase the metadata - makes the AZList nicer
388 #$metadata_value = uc($metadata_value);
389
390 # We are already working with unicode aware strings at this
391 # stage, so we no longer need to convert from utf8 to unicode
392 my $metadata_value_unicode_string = $metadata_value; # $self->convert_utf8_string_to_unicode_string($metadata_value);
393
394 # Add the metadata value into the list for this combination of metadata group and section
395 push(@{$self->{$metadata_group . ".list"}->{$section_OID}}, $metadata_value_unicode_string);
396 }
397 last if (@metadata_values > 0);
398 }
399
400 $metadata_groups_done{$metadata_group} = 1;
401 }
402 }
403}
404
405
406sub get_classify_info
407{
408 my $self = shift(@_);
409
410 # The metadata groups to classify by
411 my @metadata_groups = @{$self->{'metadata_groups'}};
412 my $first_metadata_group = $metadata_groups[0];
413
414 # The OID values of the documents to include in the classifier
415 my @OIDs = @{$self->{'OIDs'}};
416
417 # Create the root node of the classification hierarchy
418 my %classifier_node = ( 'thistype' => "Invisible",
419 'childtype' => $self->{$first_metadata_group . ".list_type"},
420 'Title' => $self->{'buttonname'},
421 'contains' => [],
422 'mdtype' => $first_metadata_group );
423
424 # Recursively create the classification hierarchy, one level for each metadata group
425 $self->add_level(\@metadata_groups, \@OIDs, \%classifier_node);
426 return \%classifier_node;
427}
428
429
430sub add_level
431{
432 my $self = shift(@_);
433 my @metadata_groups = @{shift(@_)};
434 my @OIDs = @{shift(@_)};
435 my $classifier_node = shift(@_);
436
437 my $metadata_group = $metadata_groups[0];
438
439 if (!defined($self->{$metadata_group . ".list"})) {
440 print STDERR "Warning: No metadata values assigned to $metadata_group.\n";
441 return;
442 }
443
444 # Create a mapping from metadata value to OID
445 my $OID_to_metadata_values_hash_ref = $self->{$metadata_group . ".list"};
446 my %metadata_value_to_OIDs_hash = ();
447 foreach my $OID (@OIDs)
448 {
449 if ($OID_to_metadata_values_hash_ref->{$OID})
450 {
451 my @metadata_values = @{$OID_to_metadata_values_hash_ref->{$OID}};
452 foreach my $metadata_value (@metadata_values)
453 {
454 push(@{$metadata_value_to_OIDs_hash{$metadata_value}}, $OID);
455 }
456 }
457 }
458 #print STDERR "Number of distinct values: " . scalar(keys %metadata_value_to_OIDs_hash) . "\n";
459
460 # Partition the values (if necessary)
461 my $partition_type_within_level = $self->{$metadata_group . ".partition_type_within_level"};
462 my $partition_size_within_level = $self->{$metadata_group . ".partition_size_within_level"};
463 if ($partition_type_within_level =~ /^per_letter$/i) {
464 # Generate one hlist for each letter
465 my @sortedmetadata_values = $self->sort_metadata_values_array(keys(%metadata_value_to_OIDs_hash));
466 my %metadata_value_to_OIDs_subhash = ();
467
468 my $lastpartition = substr($sortedmetadata_values[0], 0, 1);
469 foreach my $metadata_value (@sortedmetadata_values) {
470 my $metadata_valuepartition = substr($metadata_value, 0, 1);
471
472 # Is this the start of a new partition?
473 if ($metadata_valuepartition ne $lastpartition) {
474 $self->add_hlist_partition(\@metadata_groups, $classifier_node, $lastpartition, \%metadata_value_to_OIDs_subhash);
475 %metadata_value_to_OIDs_subhash = ();
476 $lastpartition = $metadata_valuepartition;
477 }
478
479 $metadata_value_to_OIDs_subhash{$metadata_value} = $metadata_value_to_OIDs_hash{$metadata_value};
480 }
481
482 # Don't forget to add the last partition
483 $self->add_hlist_partition(\@metadata_groups, $classifier_node, $lastpartition, \%metadata_value_to_OIDs_subhash);
484
485 # The partitions are stored in an HList
486 $classifier_node->{'childtype'} = "HList";
487 }
488 elsif ($partition_type_within_level =~ /^approximate_size$/i && scalar(keys %metadata_value_to_OIDs_hash) > $partition_size_within_level) {
489 # Generate hlist based on the first letter of the metadata value (like per_letter) but with restriction on the partition size
490 # If a letter has fewer items than specified by the "partition_size_within_level", then group them together if possible
491 # If a letter has more items than specified, split into several hlists.
492 # Depends on the bookshelf_type, one item can be either a document (when bookshelf_type is "never") or a metadata value (otherwise)
493 my $partition_size_within_level = $self->{$metadata_group . ".partition_size_within_level"};
494 my @sortedmetadata_values = $self->sort_metadata_values_array(keys(%metadata_value_to_OIDs_hash));
495 my $bookshelf_type = $self->{$metadata_group . ".bookshelf_type"};
496
497 # Separate values by their first letter, each form a bucket, like the per_letter partition type
498 my $last_partition = substr($sortedmetadata_values[0], 0, 1);
499 my %partition_buckets = ();
500 my @metadata_values_in_bucket = ();
501 my $num_items_in_bucket = 0;
502 foreach my $metadata_value (@sortedmetadata_values) {
503 my $metadata_valuepartition = substr($metadata_value, 0, 1);
504 if ($metadata_valuepartition ne $last_partition) {
505 my @temp_array = @metadata_values_in_bucket;
506 # Cache the values that belong to this bucket, and the number of items in this bucket, not necessary to be the same number as the metadata values
507 my %partition_info = ();
508 $partition_info{'metadata_values'} = \@temp_array;
509 $partition_info{'size'} = $num_items_in_bucket;
510 $partition_buckets{$last_partition} = \%partition_info;
511
512 @metadata_values_in_bucket = ($metadata_value);
513 $num_items_in_bucket = $bookshelf_type eq "never" ? scalar(@{$metadata_value_to_OIDs_hash{$metadata_value}}) : scalar(@metadata_values_in_bucket);
514 $last_partition = $metadata_valuepartition;
515 } else {
516 $num_items_in_bucket += $bookshelf_type eq "never" ? scalar(@{$metadata_value_to_OIDs_hash{$metadata_value}}) : scalar(@metadata_values_in_bucket);
517 push (@metadata_values_in_bucket, $metadata_value);
518 }
519 }
520 # Last one
521 my %partition_info = ();
522 $partition_info{'metadata_values'} = \@metadata_values_in_bucket;
523 $partition_info{'size'} = $num_items_in_bucket;
524 $partition_buckets{$last_partition} = \%partition_info;
525
526 my @partition_keys = $self->sort_metadata_values_array(keys(%partition_buckets));
527 for (my $i = 0; $i < scalar(@partition_keys) - 1; $i++) {
528 my $partition = $partition_keys[$i];
529 my $items_in_partition = $partition_buckets{$partition}->{'size'};
530 # Merge small buckets together, but keep the numeric bucket apart
531 if ($items_in_partition < $partition_size_within_level) {
532 my $items_in_next_partition = $partition_buckets{$partition_keys[$i+1]}->{'size'};
533 if ($items_in_partition + $items_in_next_partition <= $partition_size_within_level
534 && !(($partition =~ /^[^0-9]/ && $partition_keys[$i+1] =~ /^[0-9]/)
535 || ($partition =~ /^[0-9]/ && $partition_keys[$i+1] =~ /^[^0-9]/))) {
536 foreach my $metadata_value_to_merge (@{$partition_buckets{$partition}->{'metadata_values'}}) {
537 push(@{$partition_buckets{$partition_keys[$i+1]}->{'metadata_values'}}, $metadata_value_to_merge);
538 }
539 $partition_buckets{$partition_keys[$i+1]}->{'size'} += $items_in_partition;
540 delete $partition_buckets{$partition};
541 }
542 }
543 }
544 @partition_keys = $self->sort_metadata_values_array(keys(%partition_buckets));
545
546 # Add partitions, and divide big bucket into several
547 my $last_partition_end = "";
548 my $partition_start = "";
549 foreach my $partition (@partition_keys) {
550 my @metadata_values = $self->sort_metadata_values_array(@{$partition_buckets{$partition}->{'metadata_values'}});
551 my $items_in_partition = $partition_buckets{$partition}->{'size'};
552 $partition_start = $self->generate_partition_start($metadata_values[0], $last_partition_end, $self->{"partition_name_length"});
553
554 if ($items_in_partition > $partition_size_within_level) {
555 my $items_done = 0;
556 my %metadata_values_to_OIDs_subhashes = ();
557 for (my $i = 0; $i < scalar(@metadata_values); $i++) {
558 my $metadata_value = $metadata_values[$i];
559 # If the bookshelf_type is "never", count the documents, otherwise count the distinct metadata values
560 my $items_for_this_md_value = $bookshelf_type eq "never" ? scalar(@{$metadata_value_to_OIDs_hash{$metadata_value}}) : 1;
561
562 my $partitionend = $self->generate_partition_end($metadata_value, $partition_start, $self->{"partition_name_length"});
563 my $partitionname = $partition_start;
564 if ($partitionend ne $partition_start) {
565 $partitionname = $partitionname . "-" . $partitionend;
566 }
567
568 # Start a new partition
569 if ($items_done + $items_for_this_md_value > $partition_size_within_level && $items_done != 0) {
570 $self->add_hlist_partition(\@metadata_groups, $classifier_node, $partitionname, \%metadata_values_to_OIDs_subhashes);
571 $last_partition_end = $partitionend;
572 $partition_start = $self->generate_partition_start($metadata_value, $last_partition_end, $self->{"partition_name_length"});
573 $items_done = 0;
574 %metadata_values_to_OIDs_subhashes = ();
575 }
576
577 # If bookshelf_type is "never" and the current metadata value holds too many items, need to split into several partitions
578 if ($bookshelf_type eq "never" && $items_for_this_md_value > $partition_size_within_level) {
579 my $partitionname_for_this_value = $self->generate_partition_start($metadata_value, $last_partition_end, $self->{"partition_name_length"});
580 # Get the number of partitions needed for this value
581 my $num_splits = int($items_for_this_md_value / $partition_size_within_level);
582 $num_splits++ if ($items_for_this_md_value / $partition_size_within_level > $num_splits);
583
584 my @OIDs_for_this_value = @{$metadata_value_to_OIDs_hash{$metadata_value}};
585 for (my $i = 0; $i < $num_splits; $i++) {
586 my %OIDs_subhashes_for_this_value = ();
587 my @OIDs_for_this_partition = ();
588 for (my $d = $i * $partition_size_within_level; $d < (($i+1) * $partition_size_within_level > $items_for_this_md_value ? $items_for_this_md_value : ($i+1) * $partition_size_within_level); $d++) {
589 push (@OIDs_for_this_partition, $OIDs_for_this_value[$d]);
590 }
591
592 # The last bucket might have only a few items and need to be merged with buckets for subsequent metadata values
593 if ($i == $num_splits - 1 && scalar(@OIDs_for_this_partition) < $partition_size_within_level) {
594 $metadata_values_to_OIDs_subhashes{$metadata_value} = \@OIDs_for_this_partition;
595 $items_done += scalar(@OIDs_for_this_partition);
596 next;
597 }
598
599 # Add an HList for this bucket
600 $OIDs_subhashes_for_this_value{$metadata_value} = \@OIDs_for_this_partition;
601 $self->add_hlist_partition(\@metadata_groups, $classifier_node, $partitionname_for_this_value, \%OIDs_subhashes_for_this_value);
602 $last_partition_end = $partitionname_for_this_value;
603 }
604 next;
605 }
606
607 $metadata_values_to_OIDs_subhashes{$metadata_value} = $metadata_value_to_OIDs_hash{$metadata_value};
608 $items_done += $bookshelf_type eq "never" ? scalar(@{$metadata_values_to_OIDs_subhashes{$metadata_value}}) : 1;
609
610 # The last partition
611 if($i == scalar(@metadata_values) - 1) {
612 $self->add_hlist_partition(\@metadata_groups, $classifier_node, $partitionname, \%metadata_values_to_OIDs_subhashes);
613 }
614 }
615 }
616 else {
617 # The easier case, just add a partition
618 my %metadata_values_to_OIDs_subhashes = ();
619 for (my $i = 0; $i < scalar(@metadata_values); $i++) {
620 my $metadata_value = $metadata_values[$i];
621 $metadata_values_to_OIDs_subhashes{$metadata_value} = $metadata_value_to_OIDs_hash{$metadata_value};
622 }
623 my $last_metadata_value = $metadata_values[scalar(@metadata_values)-1];
624 my $partitionend = $self->generate_partition_end($last_metadata_value, $partition_start, $self->{"partition_name_length"});
625 my $partitionname = $partition_start;
626 if ($partitionend ne $partition_start) {
627 $partitionname = $partitionname . "-" . $partitionend;
628 }
629 $self->add_hlist_partition(\@metadata_groups, $classifier_node, $partitionname, \%metadata_values_to_OIDs_subhashes);
630 $last_partition_end = $partitionend;
631 }
632 }
633
634 # The partitions are stored in an HList
635 $classifier_node->{'childtype'} = "HList";
636
637 } # end approximate_size
638 else {
639 # Generate hlists of a certain size
640 if ($partition_type_within_level =~ /^constant_size$/i && scalar(keys %metadata_value_to_OIDs_hash) > $partition_size_within_level) {
641 my @sortedmetadata_values = $self->sort_metadata_values_array(keys(%metadata_value_to_OIDs_hash));
642 my $itemsdone = 0;
643 my %metadata_value_to_OIDs_subhash = ();
644 my $lastpartitionend = "";
645 my $partitionstart;
646 foreach my $metadata_value (@sortedmetadata_values) {
647 $metadata_value_to_OIDs_subhash{$metadata_value} = $metadata_value_to_OIDs_hash{$metadata_value};
648 $itemsdone++;
649 my $itemsinpartition = scalar(keys %metadata_value_to_OIDs_subhash);
650
651 # Is this the start of a new partition?
652 if ($itemsinpartition == 1) {
653 $partitionstart = $self->generate_partition_start($metadata_value, $lastpartitionend, $self->{"partition_name_length"});
654 }
655
656 # Is this the end of the partition?
657 if ($itemsinpartition == $partition_size_within_level || $itemsdone == @sortedmetadata_values) {
658 my $partitionend = $self->generate_partition_end($metadata_value, $partitionstart, $self->{"partition_name_length"});
659 my $partitionname = $partitionstart;
660 if ($partitionend ne $partitionstart) {
661 $partitionname = $partitionname . "-" . $partitionend;
662 }
663
664 $self->add_hlist_partition(\@metadata_groups, $classifier_node, $partitionname, \%metadata_value_to_OIDs_subhash);
665 %metadata_value_to_OIDs_subhash = ();
666 $lastpartitionend = $partitionend;
667 }
668 }
669
670 # The partitions are stored in an HList
671 $classifier_node->{'childtype'} = "HList";
672 }
673
674 # Otherwise just add all the values to a VList
675 else {
676 $self->add_vlist(\@metadata_groups, $classifier_node, \%metadata_value_to_OIDs_hash);
677 }
678 }
679}
680
681
682sub generate_partition_start
683{
684 my $self = shift(@_);
685 my $metadata_value = shift(@_);
686 my $lastpartitionend = shift(@_);
687 my $partition_name_length = shift(@_);
688
689 if ($partition_name_length) {
690 return substr($metadata_value, 0, $partition_name_length);
691 }
692
693 my $partitionstart = substr($metadata_value, 0, 1);
694 if ($partitionstart le $lastpartitionend) {
695 $partitionstart = substr($metadata_value, 0, 2);
696 # Give up after three characters
697 if ($partitionstart le $lastpartitionend) {
698 $partitionstart = substr($metadata_value, 0, 3);
699 }
700 }
701
702 return $partitionstart;
703}
704
705
706sub generate_partition_end
707{
708 my $self = shift(@_);
709 my $metadata_value = shift(@_);
710 my $partitionstart = shift(@_);
711 my $partition_name_length = shift(@_);
712
713 if ($partition_name_length) {
714 return substr($metadata_value, 0, $partition_name_length);
715 }
716
717 my $partitionend = substr($metadata_value, 0, length($partitionstart));
718 if ($partitionend gt $partitionstart) {
719 $partitionend = substr($metadata_value, 0, 1);
720 if ($partitionend le $partitionstart) {
721 $partitionend = substr($metadata_value, 0, 2);
722 # Give up after three characters
723 if ($partitionend le $partitionstart) {
724 $partitionend = substr($metadata_value, 0, 3);
725 }
726 }
727 }
728
729 return $partitionend;
730}
731
732
733sub add_hlist_partition
734{
735 my $self = shift(@_);
736 my @metadata_groups = @{shift(@_)};
737 my $classifier_node = shift(@_);
738 my $partitionname = shift(@_);
739 my $metadata_value_to_OIDs_hash_ref = shift(@_);
740
741 # Create an hlist partition
742 # Note that we don't need to convert from unicode-aware strings
743 # to utf8 here, as that is handled elsewhere in the code
744 my %child_classifier_node = ( 'Title' => $partitionname, #'Title' => $self->convert_unicode_string_to_utf8_string($partitionname),
745 'childtype' => "VList",
746 'contains' => [] );
747
748 # Add the children to the hlist partition
749 $self->add_vlist(\@metadata_groups, \%child_classifier_node, $metadata_value_to_OIDs_hash_ref);
750 push(@{$classifier_node->{'contains'}}, \%child_classifier_node);
751}
752
753
754sub add_vlist
755{
756 my $self = shift(@_);
757 my @metadata_groups = @{shift(@_)};
758 my $classifier_node = shift(@_);
759 my $metadata_value_to_OIDs_hash_ref = shift(@_);
760
761 my $metadata_group = shift(@metadata_groups);
762 $classifier_node->{'mdtype'} = $metadata_group;
763
764 # Create an entry in the vlist for each value
765 foreach my $metadata_value ($self->sort_metadata_values_array(keys(%{$metadata_value_to_OIDs_hash_ref})))
766 {
767 my @OIDs = @{$metadata_value_to_OIDs_hash_ref->{$metadata_value}};
768 # If there is only one item and 'bookshelf_type' is not always (ie. never or duplicate_only), add the item to the list
769 if (@OIDs == 1 && $self->{$metadata_group . ".bookshelf_type"} ne "always") {
770 my $OID = $OIDs[0];
771 my $offset = $self->metadata_offset($metadata_group, $OID, $metadata_value);
772 push(@{$classifier_node->{'contains'}}, { 'OID' => $OID, 'offset' => $offset });
773 }
774 # If 'bookshelf_type' is 'never', list all the items even if there are duplicated values
775 elsif ($self->{$metadata_group . ".bookshelf_type"} eq "never") {
776 @OIDs = $self->sort_leaf_items(\@OIDs);
777 foreach my $OID (@OIDs) {
778 my $offset = $self->metadata_offset($metadata_group, $OID, $metadata_value);
779 push(@{$classifier_node->{'contains'}}, { 'OID' => $OID , 'offset' => $offset });
780 }
781
782 }
783 # Otherwise create a sublist (bookshelf) for the metadata value
784 else {
785 # Note that we don't need to convert from unicode-aware strings
786 # to utf8 here, as that is handled elsewhere in the code
787 my %child_classifier_node = ( 'Title' => $metadata_value, # 'Title' => $self->convert_unicode_string_to_utf8_string($metadata_value),
788 'childtype' => "VList",
789 'mdtype' => $metadata_group,
790 'contains' => [] );
791
792 #@OIDs = $self->sort_leaf_items(\@OIDs);
793 # If there are metadata elements remaining, recursively apply the process
794 if (@metadata_groups > 0) {
795 my $next_metadata_group = $metadata_groups[0];
796 $child_classifier_node{'childtype'} = $self->{$next_metadata_group . ".list_type"};
797
798 # separate metadata into those that below in the next/sub-metadata_group
799 # and those that below at the current level's metadata_group
800
801 my $OID_to_metadata_values_hash_ref = $self->{$next_metadata_group . ".list"};
802 my @current_level_OIDs = ();
803 my @next_level_OIDs = ();
804 foreach my $OID (@OIDs)
805 {
806 if ($OID_to_metadata_values_hash_ref->{$OID}) {
807 push(@next_level_OIDs, $OID);
808 } else {
809 push(@current_level_OIDs, $OID);
810 }
811 }
812 # recursively process those docs belonging to the sub-metadata_group
813 $self->add_level(\@metadata_groups, \@next_level_OIDs, \%child_classifier_node);
814
815 # For those docs that don't belong in the sub/next_metadata_group, but which belong
816 # at this level, just add the documents as children of this list at the current level
817 @current_level_OIDs = $self->sort_leaf_items(\@current_level_OIDs);
818 foreach my $current_level_OID (@current_level_OIDs) {
819 my $offset = $self->metadata_offset($metadata_group, $current_level_OID, $metadata_value);
820 push(@{$child_classifier_node{'contains'}}, { 'OID' => $current_level_OID , 'offset' => $offset });
821 }
822 }
823 # Otherwise just add the documents as children of this list
824 else {
825 @OIDs = $self->sort_leaf_items(\@OIDs);
826 foreach my $OID (@OIDs) {
827 my $offset = $self->metadata_offset($metadata_group, $OID, $metadata_value);
828 push(@{$child_classifier_node{'contains'}}, { 'OID' => $OID , 'offset' => $offset });
829 }
830
831 }
832
833 # Add the sublist to the list
834 push(@{$classifier_node->{'contains'}}, \%child_classifier_node);
835 }
836 }
837}
838
839sub metadata_offset
840{
841 my $self = shift(@_);
842 my $metadata_group = shift(@_);
843 my $OID = shift(@_);
844 my $metadata_value = shift(@_);
845
846 my $OID_to_metadata_values_hash_ref = $self->{$metadata_group . ".list"};
847 my @metadata_values = @{$OID_to_metadata_values_hash_ref->{$OID}};
848 for (my $i = 0; $i < scalar(@metadata_values); $i++) {
849 if ($metadata_value eq $metadata_values[$i]) {
850 return $i;
851 }
852 }
853
854 return 0;
855}
856
857sub sort_leaf_items
858{
859 my $self = shift(@_);
860 my @OIDs = @{shift(@_)};
861# my $classifier_node = shift(@_);
862
863 # Sort leaf nodes and add to list
864 my @sort_leaf_nodes_using_metadata_groups = @{$self->{'sort_leaf_nodes_using_metadata_groups'}};
865 foreach my $sort_leaf_nodes_usingmetaelem (reverse @sort_leaf_nodes_using_metadata_groups) {
866 my $OID_to_metadata_values_hash_ref = $self->{$sort_leaf_nodes_usingmetaelem . ".list"};
867 # Force a stable sort (Perl 5.6's sort isn't stable)
868 # !! The [0] bits aren't ideal (multiple metadata values) !!
869 @OIDs = @OIDs[ sort {
870 if (defined($OID_to_metadata_values_hash_ref->{$OIDs[$a]} && defined($OID_to_metadata_values_hash_ref->{$OIDs[$b]})))
871 {
872 $OID_to_metadata_values_hash_ref->{$OIDs[$a]}[0] cmp $OID_to_metadata_values_hash_ref->{$OIDs[$b]}[0];
873 }
874 else
875 {
876 $a <=> $b;
877 }
878 } 0..$#OIDs ];
879 }
880 if ($self->{'reverse_sort_leaf_nodes'}) {
881 #print STDERR "reversing\n";
882 return reverse @OIDs;
883 }
884 return @OIDs;
885}
886
887
888
889sub sort_metadata_values_array
890{
891 my $self = shift(@_);
892 my @metadata_values = @_;
893
894 if ($self->{'unicode_collator'}) {
895 return $self->{'unicode_collator'}->sort(@metadata_values);
896 }
897 else {
898 return sort(@metadata_values);
899 }
900}
901
902
9031;
Note: See TracBrowser for help on using the repository browser.