root/main/trunk/model-sites-dev/heritage-nz/collect/pdf-reports/perllib/classify/AZCompactList.pm @ 33076

Revision 33076, 24.7 KB (checked in by davidb, 5 months ago)

Customized version to split up author field metadata from Heritage NZ spreadsheet; with hindsight it is probably better to be doing this in the Plugin, not the classifier

Line 
1###########################################################################
2#
3# AZCompactList.pm --
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 1999 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25# classifier plugin for sorting alphabetically
26
27package AZCompactList;
28
29use strict;
30no strict 'refs'; # allow filehandles to be variables and viceversa
31
32use BaseClassifier;
33use sorttools;
34use FileUtils;
35
36use Unicode::Normalize;
37
38sub BEGIN {
39    @AZCompactList::ISA = ('BaseClassifier');
40}
41
42our $doclevel_list =
43    [ { 'name' => "top",
44    'desc' => "{AZCompactList.doclevel.top}" },
45      { 'name' => "firstlevel",
46    'desc' => "{AZCompactList.doclevel.firstlevel}" },
47      { 'name' => "section",
48    'desc' => "{AZCompactList.doclevel.section}" } ];
49
50my $arguments =
51    [ { 'name' => "metadata",
52    'desc' => "{AZCompactList.metadata}",
53    'type' => "metadata",
54    'reqd' => "yes" },
55      { 'name' => "firstvalueonly",
56    'desc' => "{AZCompactList.firstvalueonly}",
57    'type' => "flag",
58    'reqd' => "no" },
59      { 'name' => "allvalues",
60    'desc' => "{AZCompactList.allvalues}",
61    'type' => "flag",
62    'reqd' => "no" },
63      { 'name' => "sort",
64    'desc' => "{AZCompactList.sort}",
65    'type' => "metadata",
66#   'deft' => "Title",
67    'reqd' => "no" },
68      { 'name' => "removeprefix",
69    'desc' => "{BasClas.removeprefix}",
70    'type' => "regexp",
71    'deft' => "",
72    'reqd' => "no" },
73      { 'name' => "removesuffix",
74    'desc' => "{BasClas.removesuffix}",
75    'type' => "regexp",
76    'deft' => "",
77    'reqd' => "no" },
78      { 'name' => "mingroup",
79    'desc' => "{AZCompactList.mingroup}",
80    'type' => "int",
81    'deft' => "1",
82    'range' => "1,",
83    'reqd' => "no" },
84      { 'name' => "minnesting",
85    'desc' => "{AZCompactList.minnesting}",
86    'type' => "int",
87    'deft' => "20",
88    'range' => "2,",
89    'reqd' => "no" },
90      { 'name' => "mincompact",
91    'desc' => "{AZCompactList.mincompact}",
92    'type' => "int",
93    'deft' => "10",
94    'range' => "1,",
95    'reqd' => "no" },
96      { 'name' => "maxcompact",
97    'desc' => "{AZCompactList.maxcompact}",
98    'type' => "int",
99    'deft' => "30",
100    'range' => "1,",
101    'reqd' => "no" },
102      { 'name' => "doclevel",
103    'desc' => "{AZCompactList.doclevel}",
104    'type' => "enum",
105    'list' => $doclevel_list,
106    'deft' => "top",
107    'reqd' => "no" },
108      { 'name' => "freqsort",
109    'desc' => "{AZCompactList.freqsort}",
110    'type' => "flag"},
111      { 'name' => "recopt",
112    'desc' => "{AZCompactList.recopt}",
113    'type' => "flag",
114    'reqd' => "no" } ];
115
116my $options =
117{   'name'     => "AZCompactList",
118    'desc'     => "{AZCompactList.desc}",
119    'abstract' => "no",
120    'inherits' => "yes",
121    'args'     => $arguments };
122
123
124sub new {
125    my ($class) = shift (@_);
126    my ($pluginlist,$inputargs,$hashArgOptLists) = @_;
127    push(@$pluginlist, $class);
128
129    push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});
130    push(@{$hashArgOptLists->{"OptList"}},$options);
131
132    my $self = new BaseClassifier($pluginlist, $inputargs, $hashArgOptLists);
133
134    if ($self->{'info_only'}) {
135    # don't worry about any options etc
136    return bless $self, $class;
137    }
138   
139    if (!$self->{"metadata"}) {
140    my $outhandle = $self->{'outhandle'};
141    print $outhandle "AZCompactList Error: required option -metadata not supplied\n";
142    $self->print_txt_usage(""); 
143    die "AZCompactList Error: required option -metadata not supplied\n";
144    }
145
146    $self->{'metadata'} = $self->strip_ex_from_metadata($self->{'metadata'});
147    # Manually set $self parameters.
148    $self->{'list'} = {};
149    $self->{'listmetavalue'} = {};
150    $self->{'list_mvpair'} = {};
151    $self->{'reclassify'} = {};
152    $self->{'reclassifylist'} = {};
153
154    $self->{'buttonname'} = $self->generate_title_from_metadata($self->{'metadata'}) unless ($self->{'buttonname'});
155   
156    if (defined($self->{"removeprefix"}) && $self->{"removeprefix"}) {
157    $self->{"removeprefix"} =~ s/^\^//; # don't need a leading ^
158    }
159    if (defined($self->{"removesuffix"}) && $self->{"removesuffix"}) {
160    $self->{"removesuffix"} =~ s/\$$//; # don't need a trailing $
161    }
162   
163    $self->{'recopt'} = ($self->{'recopt'} == 0) ? undef : "on";
164   
165    if (defined $self->{'sort'}) {
166    $self->{'sort'} = $self->strip_ex_from_metadata($self->{'sort'});
167    }
168    # Clean out the unused keys
169    if($self->{"removeprefix"} eq "") {delete $self->{"removeprefix"};}
170    if($self->{"removesuffix"} eq "") {delete $self->{"removesuffix"};}
171
172    return bless $self, $class;
173}
174
175sub init
176{
177    my $self = shift (@_);
178   
179    $self->{'list'} = {};
180    $self->{'listmetavalue'} = {};
181    $self->{'list_mvpair'} = {};
182    $self->{'reclassify'} = {};
183    $self->{'reclassifylist'} = {};
184}
185
186my $tmp = 0;
187
188sub classify
189{
190    my $self = shift (@_);
191    my ($doc_obj) = @_;
192
193    my $doc_OID = $doc_obj->get_OID();
194    my $outhandle = $self->{'outhandle'};
195
196    my @sectionlist = ();
197    my $topsection = $doc_obj->get_top_section();
198    my $metaname = $self->{'metadata'};
199
200    $metaname =~ s/(\/|\|).*//; # grab first name in n1/n2/n3 or n1|n2|n3 list
201    my @commameta_list = split(/,|;/, $metaname);
202
203    if ($self->{'doclevel'} =~ /^top(level)?/i)
204    {
205    push(@sectionlist,$topsection);
206    }
207    elsif ($self->{'doclevel'} =~ /^first(level)?/i)
208    {
209    my $toplevel_children = $doc_obj->get_children($topsection);
210    push(@sectionlist,@$toplevel_children);
211    }
212    else # (all)?section(s)?
213    {
214    my $thissection = $doc_obj->get_next_section($topsection);
215    while (defined $thissection)
216    {
217        push(@sectionlist,$thissection);
218        $thissection = $doc_obj->get_next_section ($thissection);
219    }
220    }
221
222    my $thissection;
223    foreach $thissection (@sectionlist)
224    {
225    my $full_doc_OID
226        = ($thissection ne "") ? "$doc_OID.$thissection" : $doc_OID;
227
228    if (defined $self->{'list_mvpair'}->{$full_doc_OID})
229    {
230        print $outhandle "WARNING: AZCompactList::classify called multiple times for $full_doc_OID\n";
231    }
232    $self->{'list'}->{$full_doc_OID} = []; 
233    $self->{'listmetavalue'}->{$full_doc_OID} = [];
234    $self->{'list_mvpair'}->{$full_doc_OID} = [];
235
236    # if specified, used to further split a metavalue
237    # split on:
238    #   | / or 'Unicode Character 'BOX DRAWINGS LIGHT VERTICAL' (U+2502)'
239    # *except* when 'n/a'
240
241    my $split_on_re_str = "(?!^[n])[&|\/\x{2502}](?![a]\$)";
242    # my $split_on_re_str = "[|\/\x{2502}]";
243    my $split_on_re = /$split_on_re_str/;
244
245    my $metavalues = [];
246    foreach my $cmn (@commameta_list) {
247        my $cmvalues = $doc_obj->get_metadata($thissection,$cmn);
248        if (@{$cmvalues}) {
249        # see if further splitting is required, due to 'split_on' field
250        if ($split_on_re) {
251       
252            my $further_split_cmvalues = [];
253           
254            foreach my $cmval (@$cmvalues) {
255            my @split_cmval = split(/$split_on_re_str/,$cmval);
256
257            push(@$further_split_cmvalues,@split_cmval);
258            last if (@{$cmval} && !$self->{'allvalues'});
259            }
260
261            $cmvalues = $further_split_cmvalues;
262        }
263        }
264        if (@{$cmvalues}) {
265        if ($self->{'allvalues'}) {
266            push(@$metavalues,@$cmvalues);
267        }
268        else {
269            # only want first one, then break out of loop
270            push(@$metavalues,$cmvalues->[0]);
271            last;
272        }
273        }
274    }
275
276    my $metavalue;
277    foreach $metavalue (@$metavalues)
278    {
279        # Tidy up use of white space in metavalue for classifying
280        $metavalue =~ s/^\s*//s;
281        $metavalue =~ s/\s*$//s;
282        $metavalue =~ s/\n/ /s;
283        $metavalue =~ s/\s{2,}/ /s;
284
285        # if this document doesn't contain the metadata element we're
286        # sorting by we won't include it in this classification
287        if (defined $metavalue && $metavalue =~ /\w/)
288        {
289        if (defined($self->{'removeprefix'}) &&
290            length($self->{'removeprefix'})) {
291            $metavalue =~ s/^$self->{'removeprefix'}//;
292
293            # check that it's not now empty
294            if (!$metavalue) {next;}
295        }
296
297        if (defined($self->{'removesuffix'}) &&
298            length($self->{'removesuffix'})) {
299            $metavalue =~ s/$self->{'removesuffix'}$//;
300
301            # check that it's not now empty
302            if (!$metavalue) {next;}
303        }
304
305        my $formatted_metavalue;
306        if ($self->{'no_metadata_formatting'}) {
307            $formatted_metavalue = $metavalue;
308        } else {
309            $formatted_metavalue = &sorttools::format_metadata_for_sorting($self->{'metadata'},  $metavalue, $doc_obj);
310        }
311       
312        #### prefix-str
313        if (! defined($formatted_metavalue)) {
314            print $outhandle "Warning: AZCompactList: metavalue is ";
315            print $outhandle "empty\n";
316            $formatted_metavalue="";
317        }
318
319        my $mv_pair = { 'mv' => $metavalue, 'fmv' => $formatted_metavalue };
320        push(@{$self->{'list'}->{$full_doc_OID}},$formatted_metavalue);
321        push(@{$self->{'listmetavalue'}->{$full_doc_OID}} ,$metavalue);
322        push(@{$self->{'list_mvpair'}->{$full_doc_OID}},$mv_pair);
323
324
325        last if ($self->{'firstvalueonly'});
326        }
327    }
328
329    # This is used in reclassify below for AZCompactSectionList
330    my $sortmeta = $doc_obj->get_metadata_element($thissection, $self->{'sort'});
331    $self->{'reclassify'}->{$full_doc_OID} = [$doc_obj,$sortmeta];
332    }
333}
334
335sub reinit
336{
337    my ($self,$classlist_ref) = @_;
338    my $outhandle = $self->{'outhandle'};
339   
340    my %mtfreq = ();
341    my @single_classlist = ();
342    my @multiple_classlist = ();
343
344    # find out how often each metavalue occurs
345    map
346    {
347    foreach my $mvp (@{$self->{'list_mvpair'}->{$_}} )
348    {
349###     print STDERR "*** plain mv = $mvp->{'mv'}\n";
350###     print STDERR "*** format mv = $mvp->{'fmv'}\n";
351
352        my $metavalue = $mvp->{'mv'};
353        $metavalue =~ s!^-!\\-!; # in case it starts with "-"
354        $mtfreq{$metavalue}++;
355    }
356    } @$classlist_ref;
357
358    # use this information to split the list: single metavalue/repeated value
359    map
360    {
361    my $i = 1;
362    my $metavalue;
363    foreach my $mvp (@{$self->{'list_mvpair'}->{$_}})
364    {
365        my $metavalue = $mvp->{'mv'};
366        $metavalue =~ s!^-!\\-!; # in case it starts with "-"
367        my $cs_metavalue = $mvp->{'mv'}; # case sensitive
368        if ($mtfreq{$metavalue} >= $self->{'mingroup'})
369        {
370###     print STDERR "*** pushing on $cs_metavalue\n";
371        push(@multiple_classlist,[$_,$i,$metavalue]);
372        }
373        else
374        {
375        push(@single_classlist,[$_,$cs_metavalue]);
376        $metavalue =~ tr/[A-Z]/[a-z]/;
377        $self->{'reclassifylist'}->{"Metavalue_$i.$_"} = $metavalue;
378        }
379        $i++;
380    }
381    } @$classlist_ref;
382   
383   
384    # Setup sub-classifiers for multiple list
385
386    $self->{'classifiers'} = {};
387
388    my $pm;
389    foreach $pm ("SimpleList", "SectionList")
390    {
391    my $listname
392        = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"perllib/classify/$pm.pm");
393    if (-e $listname) { require $listname; }
394    else
395    {
396        print $outhandle "AZCompactList ERROR - couldn't find classifier \"$listname\"\n";
397        die "\n";
398    }
399    }
400
401    # Create classifiers objects for each entry >= mingroup
402    my $metavalue;
403    my $doclevel = $self->{'doclevel'};
404    my $mingroup = $self->{'mingroup'};
405    my @metaname_list = split(/\/|\|/,$self->{'metadata'});
406    my $metaname = shift(@metaname_list);
407    my $hierarchical = 0;
408    if (scalar(@metaname_list) > 1) {
409    $hierarchical = 1;
410    $metaname = join('/',@metaname_list);
411    }
412    foreach $metavalue (sort keys %mtfreq)
413    {
414    if ($mtfreq{$metavalue} >= $mingroup)
415    {
416        # occurs more often than minimum required to compact into a group
417        my $listclassobj;
418       
419        if (!$hierarchical)
420        {   
421        my @args;
422        push @args, ("-metadata", "$metaname");
423        # buttonname is also used for the node's title
424        push @args, ("-buttonname", "$metavalue");
425        push @args, ("-sort", $self->{'sort'});
426
427        my $ptArgs = \@args;
428        if ($doclevel =~ m/^top(level)?/i)
429        {
430            eval ("\$listclassobj = new SimpleList([],\$ptArgs)");
431        }
432        else
433        {
434            # first(level)? or (all)?section(s)?
435            eval ("\$listclassobj = new SectionList([],\$ptArgs)");
436        }
437        }
438        else
439        {
440       
441        my @args;
442        push @args, ("-metadata", "$metaname");
443        # buttonname is also used for the node's title
444        push @args, ("-buttonname", "$metavalue");
445        push @args, ("-sort", $self->{'sort'});
446
447        if (defined $self->{'removeprefix'}) {
448            push @args, ("-removeprefix", $self->{'removeprefix'});
449        }
450        if (defined $self->{'removesuffix'}) {
451            push @args, ("-removesuffix", $self->{'removesuffix'});
452        }
453       
454        push @args, ("-doclevel", "$doclevel");
455        push @args, ("-mingroup", $mingroup);
456        push @args, "-recopt ";
457
458        my $ptArgs = \@args;
459        eval ("\$listclassobj = new AZCompactList([],\$ptArgs)");
460        }
461       
462        if ($@) {
463        print $outhandle "$@";
464        die "\n";
465        }
466       
467        $listclassobj->init();
468
469        if (defined $metavalue && $metavalue =~ /\w/)
470        {
471        my $formatted_node = $metavalue;
472
473        if (defined($self->{'removeprefix'}) &&
474            length($self->{'removeprefix'})) {
475            $formatted_node =~ s/^$self->{'removeprefix'}//;
476            # check that it's not now empty
477            if (!$formatted_node) {next;}
478        }
479        if (defined($self->{'removesuffix'}) &&
480            length($self->{'removesuffix'})) {
481            $formatted_node =~ s/$self->{'removesuffix'}$//;
482            # check that it's not now empty
483            if (!$formatted_node) {next;}
484        }
485
486        $formatted_node = &sorttools::format_metadata_for_sorting($self->{'metadata'}, $formatted_node) unless $self->{'no_metadata_formatting'};
487
488        # In case our formatted string is empty...
489        if (! defined($formatted_node)) {
490            print $outhandle "Warning: AZCompactList: metavalue is ";
491            print $outhandle "empty\n";
492            $formatted_node="";
493        }
494
495        # use the lower case, for speed of lookup.
496        my $meta_lc=lc($metavalue);
497        $self->{'classifiers'}->{$meta_lc}
498        = { 'classifyobj'   => $listclassobj,
499            'formattednode' => $formatted_node };
500        }
501    }
502    }
503
504
505    return (\@single_classlist,\@multiple_classlist);
506}
507
508
509sub reclassify
510{
511    my ($self,$multiple_cl_ref) = @_;
512
513    # Entries in the current classify list that are "book nodes"
514    # should be recursively classified.
515    #--
516    foreach my $dm_pair (@$multiple_cl_ref)
517    {
518    my ($doc_OID,$mdoffset,$metavalue,$cs_metavalue) = @$dm_pair;
519        my $listclassobj;
520
521    # find metavalue in list of sub-classifiers
522    # check if we have a key (lower case) for this metadata value
523    my $node_name=lc($metavalue);
524    if (exists $self->{'classifiers'}->{$node_name})
525    {
526        my ($doc_obj, $sortmeta) = @{$self->{'reclassify'}->{$doc_OID}};
527
528        # record the metadata value offset temporarily, so eg AZList can
529        # get the correct metadata value (for multi-valued metadata fields)
530        $doc_obj->{'mdoffset'}=$mdoffset;
531
532        if ($doc_OID =~ m/^[^\.]*\.([\d\.]+)$/)
533        {
534        my $section=$1;
535        if ($self->{'doclevel'} =~ m/^top(level)?/i) { # toplevel
536            $self->{'classifiers'}->{$node_name}->{'classifyobj'}
537            ->classify($doc_obj,"Section=$section");
538        } else {
539            # first(level)? or (all)?section(s)?
540
541            # classify() can't handle multi-level section, so use
542            # classify_section()
543            # ... thanks to Don Gourley for this...
544
545            $self->{'classifiers'}->{$node_name}->{'classifyobj'}
546            ->classify_section($section, $doc_obj, $sortmeta);
547        }
548        }
549        else
550        {
551        $self->{'classifiers'}->{$node_name}->{'classifyobj'}
552        ->classify($doc_obj);
553        }
554    } else { # this key is not in the hash
555        my $outhandle=$self->{outhandle};
556        print $outhandle "Warning: AZCompactList::reclassify ";
557        print $outhandle "could not find sub-node for metadata=`$metavalue' with doc_OID $doc_OID\n";
558    }
559    }
560}
561
562
563
564sub get_reclassify_info
565{
566    my $self = shift (@_);
567   
568    my $node_name;
569    foreach $node_name (keys %{$self->{'classifiers'}})
570    {
571        my $classifyinfo
572        = $self->{'classifiers'}->{$node_name}->{'classifyobj'}
573            ->get_classify_info();
574        $self->{'classifiers'}->{$node_name}->{'classifyinfo'}
575        = $classifyinfo;
576        $self->{'reclassifylist'}->{"CLASSIFY.$node_name"}
577        = $self->{'classifiers'}->{$node_name}->{'formattednode'};
578    }
579}
580
581
582sub alpha_numeric_cmp
583{
584    my ($self,$a,$b) = @_;
585
586    my $title_a = $self->{'reclassifylist'}->{$a};
587    my $title_b = $self->{'reclassifylist'}->{$b};
588   
589    if ($title_a =~ m/^(\d+(\.\d+)?)/)
590    {
591    my $val_a = $1;
592    if ($title_b =~ m/^(\d+(\.\d+)?)/)
593    {
594        my $val_b = $1;
595        if ($val_a != $val_b)
596        {
597        return ($val_a <=> $val_b);
598        }
599    }
600    }
601   
602    return ($title_a cmp $title_b);
603}
604
605sub frequency_cmp
606{
607    my ($self,$a,$b) = @_;
608
609
610    my $title_a = $self->{'reclassifylist'}->{$a};
611    my $title_b = $self->{'reclassifylist'}->{$b};
612
613    my $a_freq = 1;
614    my $b_freq = 1;
615
616    if ($a =~ m/^CLASSIFY\.(.*)$/)
617    {
618    my $a_node = $1;
619    my $a_nodeinfo = $self->{'classifiers'}->{$a_node}->{'classifyinfo'};
620    $a_freq = scalar(@{$a_nodeinfo->{'contains'}});
621    }
622   
623    if ($b =~ m/^CLASSIFY\.(.*)$/)
624    {
625    my $b_node = $1;
626    my $b_nodeinfo = $self->{'classifiers'}->{$b_node}->{'classifyinfo'};
627    $b_freq = scalar(@{$b_nodeinfo->{'contains'}});
628    }
629
630    return $b_freq <=> $a_freq;
631}
632
633sub get_classify_info {
634    my $self = shift (@_);
635
636    my @classlist =keys %{$self->{'list_mvpair'}}; # list all doc oids
637
638    my ($single_cl_ref,$multiple_cl_ref) = $self->reinit(\@classlist);
639    $self->reclassify($multiple_cl_ref);
640    $self->get_reclassify_info();
641
642    my @reclassified_classlist;
643    if ($self->{'freqsort'})
644    {
645    @reclassified_classlist
646        = sort { $self->frequency_cmp($a,$b) } keys %{$self->{'reclassifylist'}};
647    # supress sub-grouping by alphabet
648    map { $self->{'reclassifylist'}->{$_} = "A".$self->{'reclassifylist'}; } keys %{$self->{'reclassifylist'}};
649    }
650    else
651    {
652#   @reclassified_classlist
653#       = sort {$self->{'reclassifylist'}->{$a} cmp $self->{'reclassifylist'}->{$b};} keys %{$self->{'reclassifylist'}};
654
655    # alpha_numeric_cmp is slower than "cmp" but handles numbers better ...
656
657    @reclassified_classlist
658        = sort { $self->alpha_numeric_cmp($a,$b) } keys %{$self->{'reclassifylist'}};
659
660    }
661
662    return $self->splitlist (\@reclassified_classlist);
663}
664
665sub get_entry {
666    my $self = shift (@_);
667    my ($title, $childtype, $metaname, $thistype) = @_;
668    # organise into classification structure
669    my %classifyinfo = ('childtype'=>$childtype,
670                        'Title'=>$title,
671                        'contains'=>[],
672            'mdtype'=>$metaname);
673
674    $classifyinfo{'thistype'} = $thistype
675        if defined $thistype && $thistype =~ /\w/;
676
677    return \%classifyinfo;
678}
679
680
681
682# splitlist takes an ordered list of classifications (@$classlistref) and
683# splits it up into alphabetical sub-sections.
684sub splitlist {
685    my $self = shift (@_);
686    my ($classlistref) = @_;
687    my $classhash = {};
688
689    # top level
690    my @metanames = split(/\/|\|/,$self->{'metadata'});
691    my $metaname = shift(@metanames);
692
693    my $childtype = "HList";
694    $childtype = "VList" if (scalar (@$classlistref) <= $self->{'minnesting'});
695
696    my $title = $self->{'buttonname'}; # should always be defined by now.
697    my $classifyinfo;
698    if (!defined($self->{'recopt'}))
699    {
700    $classifyinfo
701        = $self->get_entry ($title, $childtype, $metaname, "Invisible");
702    }
703    else
704    {
705    $classifyinfo
706        = $self->get_entry ($title, $childtype, $metaname, "VList");
707    }
708
709    # don't need to do any splitting if there are less than 'minnesting' classifications
710    if ((scalar @$classlistref) <= $self->{'minnesting'}) {
711    foreach my $subOID (@$classlistref) {
712            if ($subOID =~ /^CLASSIFY\.(.*)$/
713        && defined $self->{'classifiers'}->{$1})
714        {
715                push (@{$classifyinfo->{'contains'}},
716              $self->{'classifiers'}->{$1}->{'classifyinfo'});
717            }
718        else
719        {
720        $subOID =~ s/^Metavalue_(\d+)\.//;
721        my $metaname_offset = $1 -1;
722        my $oid_rec = {'OID'=>$subOID, 'offset'=>$metaname_offset};
723        push (@{$classifyinfo->{'contains'}}, $oid_rec);
724        }
725    }
726    return $classifyinfo;
727    }
728   
729    # first split up the list into separate A-Z and 0-9 classifications
730    foreach my $classification (@$classlistref) {
731    my $title = $self->{'reclassifylist'}->{$classification};
732    $title =~ s/&(.){2,4};//g; # remove any HTML special chars
733    $title =~ s/^(\W|_)+//g; # remove leading non-word chars
734
735    # only want first character for classification
736    $title =~ m/^(.)/; # always a char, or first byte of wide char?
737    if (defined($1) && $1 ne "") {
738        $title=$1;
739
740        # remove any accents on initial character by mapping to Unicode's
741        # normalized decomposed form (accents follow initial letter)
742        # and then pick off the initial letter
743        my $title_decomposed = NFD($title);
744        $title = substr($title_decomposed,0,1);
745    } else {
746        print STDERR "no first character found for \"$title\" - \"" .
747        $self->{'reclassifylist'}->{$classification} . "\"\n";
748    }
749    $title =~ tr/[a-z]/[A-Z]/;
750
751    if ($title =~ /^[0-9]$/) {$title = '0-9';}
752    elsif ($title !~ /^[A-Z]$/) {
753        my $outhandle = $self->{'outhandle'};
754        print $outhandle "AZCompactList: WARNING $classification has badly formatted title ($title)\n";
755    }
756    $classhash->{$title} = [] unless defined $classhash->{$title};
757    push (@{$classhash->{$title}}, $classification);
758    }
759    $classhash = $self->compactlist ($classhash);
760
761    my @tmparr = ();
762    foreach my $subsection (sort keys (%$classhash)) {
763    push (@tmparr, $subsection);
764    }
765   
766    # if there's a 0-9 section it will have been sorted to the beginning
767    # but we want it at the end
768    if ($tmparr[0] eq '0-9') {
769    shift @tmparr;
770    push (@tmparr, '0-9');
771    }
772    foreach my $subclass (@tmparr)
773    {
774    my $tempclassify
775        = (scalar(@tmparr)==1)
776        ? ($self->get_entry(" ", "VList", $metaname))
777        : ($self->get_entry($subclass, "VList", $metaname));
778
779
780    foreach my $subsubOID (@{$classhash->{$subclass}})
781    {
782            if ($subsubOID =~ /^CLASSIFY\.(.*)$/
783        && defined $self->{'classifiers'}->{$1})
784        {
785        # this is a "bookshelf" node... >1 entry compacted
786                push (@{$tempclassify->{'contains'}},
787              $self->{'classifiers'}->{$1}->{'classifyinfo'});
788        # set the metadata field name, for mdoffset to work
789        $self->{'classifiers'}->{$1}->{'classifyinfo'}->{'mdtype'}=
790            $metaname;
791        }
792        else
793        {
794        $subsubOID =~ s/^Metavalue_(\d+)\.//;
795        # record the offset if this metadata type has multiple values
796        my $metaname_offset = $1 -1;
797        my $oid_rec = {'OID'=>$subsubOID, 'offset'=>$metaname_offset};
798        push (@{$tempclassify->{'contains'}}, $oid_rec);
799        }
800    }
801    push (@{$classifyinfo->{'contains'}}, $tempclassify);
802    }
803
804    return $classifyinfo;
805}
806
807sub compactlist {
808    my $self = shift (@_);
809    my ($classhashref) = @_;
810    my $compactedhash = {};
811    my @currentOIDs = ();
812    my $currentfirstletter = "";
813    my $currentlastletter = "";
814    my $lastkey = "";
815
816    # minimum and maximum documents to be displayed per page.
817    # the actual maximum will be max + (min-1).
818    # the smallest sub-section is a single letter at present
819    # so in this case there may be many times max documents
820    # displayed on a page.
821    my $min = $self->{'mincompact'};
822    my $max = $self->{'maxcompact'};
823
824    foreach my $subsection (sort keys %$classhashref) {
825    if ($subsection eq '0-9') {
826        @{$compactedhash->{$subsection}} = @{$classhashref->{$subsection}};
827        next;
828    }
829    $currentfirstletter = $subsection if $currentfirstletter eq "";
830    if ((scalar (@currentOIDs) < $min) ||
831        ((scalar (@currentOIDs) + scalar (@{$classhashref->{$subsection}})) <= $max)) {
832        push (@currentOIDs, @{$classhashref->{$subsection}});
833        $currentlastletter = $subsection;
834    } else {
835
836        if ($currentfirstletter eq $currentlastletter) {
837        @{$compactedhash->{$currentfirstletter}} = @currentOIDs;
838        $lastkey = $currentfirstletter;
839        } else {
840        @{$compactedhash->{"$currentfirstletter-$currentlastletter"}} = @currentOIDs;
841        $lastkey = "$currentfirstletter-$currentlastletter";
842        }
843        if (scalar (@{$classhashref->{$subsection}}) >= $max) {
844        $compactedhash->{$subsection} = $classhashref->{$subsection};
845        @currentOIDs = ();
846        $currentfirstletter = "";
847        $lastkey=$subsection;
848        } else {
849        @currentOIDs = @{$classhashref->{$subsection}};
850        $currentfirstletter = $subsection;
851        $currentlastletter = $subsection;
852        }
853    }
854    }
855
856    # add final OIDs to last sub-classification if there aren't many otherwise
857    # add final sub-classification
858
859    # don't add if there aren't any oids
860    if (! scalar (@currentOIDs)) {return $compactedhash;}
861
862    if (scalar (@currentOIDs) < $min) {
863    my ($newkey) = $lastkey =~ /^(.)/;
864    @currentOIDs = (@{$compactedhash->{$lastkey}}, @currentOIDs);
865    delete $compactedhash->{$lastkey};
866    @{$compactedhash->{"$newkey-$currentlastletter"}} = @currentOIDs;
867    } else {
868    if ($currentfirstletter eq $currentlastletter) {
869        @{$compactedhash->{$currentfirstletter}} = @currentOIDs;
870    } else {
871        @{$compactedhash->{"$currentfirstletter-$currentlastletter"}} = @currentOIDs;
872    }
873    }
874
875    return $compactedhash;
876}
877
8781;
879
880
Note: See TracBrowser for help on using the browser.