[scpubgit/stemmatology.git] / lib / Text / Tradition / Parser / Tabular.pm

package Text::Tradition::Parser::Tabular;

use strict;
use warnings;
use Text::CSV;

=head1 NAME

Text::Tradition::Parser::Tabular

=head1 SYNOPSIS

  use Text::Tradition;
  
  my $t_from_file = Text::Tradition->new( 
    'name' => 'my text',
    'input' => 'Tabular',
    'file' => '/path/to/collation.csv',
    'sep_char' => ','
    );
    
  my $t_from_string = Text::Tradition->new( 
    'name' => 'my text',
    'input' => 'Tabular',
    'string' => $tab_separated_collation,
    'sep_char' => "\t",
    );

=head1 DESCRIPTION

Parser module for Text::Tradition to read an alignment table format, such as CSV.

=head1 METHODS

=head2 B<parse>( $tradition, $option_hash )

Takes an initialized tradition and a set of options; creates the
appropriate nodes and edges on the graph, as well as the appropriate
witness objects.  The $option_hash must contain either a 'file' or a
'string' argument with the table to be parsed; it may also contain a 
'sep_char' argument to specify how the fields are separated.

The table should have witnesses arranged in columns, with the witness sigla
in the first row.  Empty cells are interpreted as omissions (and thus
stemmatologically relevant.) Longer lacunae in the text, to be disregarded
in cladistic analysis, may be represented by filling the appropriate cells
with the tag '#LACUNA#'.

If a witness name ends in the collation's ac_label, it will be treated as
an 'ante-correction' version of the 'main' witness whose sigil it shares.

=begin testing

use Text::Tradition;
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8";
eval { no warnings; binmode $DB::OUT, ":utf8"; };

my $csv = 't/data/florilegium.csv';
my $t = Text::Tradition->new( 
    'name'  => 'inline', 
    'input' => 'Tabular',
    'file'  => $csv,
    'sep_char' => ',',
    );

is( ref( $t ), 'Text::Tradition', "Parsed florilegium CSV file" );

### TODO Check these figures
if( $t ) {
    is( scalar $t->collation->readings, 311, "Collation has all readings" );
    is( scalar $t->collation->paths, 361, "Collation has all paths" );
    is( scalar $t->witnesses, 13, "Collation has all witnesses" );
}

# Check that we have the right witnesses
my %seen_wits;
map { $seen_wits{$_} = 0 } qw/ A B C D E F G H K P Q S T /;
foreach my $wit ( $t->witnesses ) {
	$seen_wits{$wit->sigil} = 1;
}
is( scalar keys %seen_wits, 13, "No extra witnesses were made" );
foreach my $k ( keys %seen_wits ) {
	ok( $seen_wits{$k}, "Witness $k still exists" );
}

# Check that the witnesses have the right texts
foreach my $wit ( $t->witnesses ) {
	my $origtext = join( ' ', @{$wit->text} );
	my $graphtext = $t->collation->path_text( $wit->sigil );
	is( $graphtext, $origtext, "Collation matches original for witness " . $wit->sigil );
}

# Check that the a.c. witnesses have the right text
map { $seen_wits{$_} = 0 } qw/ A B C D F G H K S /;
foreach my $k ( keys %seen_wits ) {
	my $wit = $t->witness( $k );
	if( $seen_wits{$k} ) {
		ok( $wit->is_layered, "Witness $k got marked as layered" );
		ok( $wit->has_layertext, "Witness $k has an a.c. version" );
		my $origtext = join( ' ', @{$wit->layertext} );
		my $acsig = $wit->sigil . $t->collation->ac_label;
		my $graphtext = $t->collation->path_text( $acsig );
		is( $graphtext, $origtext, "Collation matches original a.c. for witness $k" );
	} else {
		ok( !$wit->is_layered, "Witness $k not marked as layered" );
		ok( !$wit->has_layertext, "Witness $k has no a.c. version" );
	}
}	

# Check that we only have collation relationships where we need them
is( scalar $t->collation->relationships, 3, "Redundant collations were removed" );

=end testing

=cut

sub parse {
    my( $tradition, $opts ) = @_;
    my $c = $tradition->collation; # shorthand
    my $csv_options = { 'binary' => 1 };
    $csv_options->{'sep_char'} = $opts->{'sep_char'} || "\t";
    if( $csv_options->{'sep_char'} eq "\t" ) {
    	# If it is really tab separated, nothing is an escape char.
    	$csv_options->{'quote_char'} = undef;
    	$csv_options->{'escape_char'} = undef;
    }
    my $csv = Text::CSV->new( $csv_options );
    
    my $alignment_table;
    if( exists $opts->{'string' } ) {
        my @lines = split( "\n", $opts->{'string'} );
        foreach my $l ( @lines ) {
            my $status = $csv->parse( $l );
            if( $status ) {
                push( @$alignment_table, [ $csv->fields ] );
            } else {
                warn "Could not parse line $l: " . $csv->error_input;
            }
        }
    } elsif( exists $opts->{'file'} ) {
        open( my $fh, $opts->{'file'} ) 
            or warn "Could not open input file " . $opts->{'file'};
        binmode( $fh, ':utf8' );
        while( my $row = $csv->getline( $fh ) ) {
            push( @$alignment_table, $row );
        }
        close $fh;
    } else {
        warn "Could not find string or file option to parse";
        return;
    }

    # Set up the witnesses we find in the first line
    my @witnesses;
    my %ac_wits;  # Track layered witness -> main witness mapping
    my $aclabel = $c->ac_label;
    foreach my $sigil ( @{$alignment_table->[0]} ) {
        if( $sigil =~ /^(.*)\Q$aclabel\E$/ ) {
        	# Sanitize the sigil name to an XML name
        	$sigil = $1 . '_layered';
            $ac_wits{$sigil} = $1;
        }
        my $wit = $tradition->add_witness( 
        	'sigil' => $sigil, 'sourcetype' => 'collation' );
        $wit->path( [ $c->start ] );
        push( @witnesses, $wit );
        my $aclabel = $c->ac_label;
    }
    
    # Save the original witness text sequences. Have to loop back through
    # the witness columns after we have identified all the a.c. witnesses.
    foreach my $idx ( 0 .. $#{$alignment_table->[0]} ) {
    	my @sequence = map { $_->[$idx] } @{$alignment_table};
    	my $sigil = shift @sequence;
    	my $is_layer = exists( $ac_wits{$sigil} );
    	my $wit = $tradition->witness( $is_layer ? $ac_wits{$sigil} : $sigil );	
    	# Now get rid of gaps and meta-readings like #LACUNA#
    	my @words = grep { $_ && $_ !~ /^\#.*\#$/ } @sequence;
    	$is_layer ? $wit->layertext( \@words ) : $wit->text( \@words );
    }    
    
    my $nocollate = ( scalar( @witnesses ) * scalar @$alignment_table ) > 150000;
    print STDERR "Tradition too big for row collation\n" if $nocollate;
    
    # Now for the next rows, make nodes as necessary, assign their ranks, and 
    # add them to the witness paths.
    foreach my $idx ( 1 .. $#{$alignment_table} ) {
        my $row = $alignment_table->[$idx];
        my $nodes = _make_nodes( $c, $row, $idx, $nocollate );
        foreach my $w ( 0 .. $#{$row} ) {
            # push the appropriate node onto the appropriate witness path
            my $word = $row->[$w];
            if( $word ) {
                my $reading = $nodes->{$word};
                my $wit = $witnesses[$w];
                push( @{$wit->path}, $reading );
            } # else skip it for empty readings.
        }
    }
    
    # Collapse our lacunae into a single node and
    # push the end node onto all paths.
    $c->end->rank( scalar @$alignment_table );
    foreach my $wit ( @witnesses ) {
        my $p = $wit->path;
        my $last_rdg = shift @$p;
        my $new_p = [ $last_rdg ];
        foreach my $rdg ( @$p ) {
        	# Omit the reading if we are in a lacuna already.
        	next if $rdg->is_lacuna && $last_rdg->is_lacuna;
			# Save the reading otherwise.
			push( @$new_p, $rdg );
			$last_rdg = $rdg;
        }
        push( @$new_p, $c->end );
        $wit->path( $new_p );
    }
    
    # Fold any a.c. witnesses into their main witness objects, and
    # delete the independent a.c. versions.
    foreach my $a ( keys %ac_wits ) {
    	my $ac_wit = $tradition->witness( $a );
        my $main_wit = $tradition->witness( $ac_wits{$a} );
        next unless $main_wit;
        $main_wit->is_layered(1);
        $main_wit->uncorrected_path( $ac_wit->path );
        $tradition->del_witness( $ac_wit );
    }
    
    # Join up the paths.
    $c->make_witness_paths;
    # Delete our unused lacuna nodes.
	foreach my $rdg ( grep { $_->is_lacuna } $c->readings ) {
		$c->del_reading( $rdg ) unless $c->reading_witnesses( $rdg );
	}
	
	# Do a consistency check.
	foreach my $wit ( $tradition->witnesses ) {
		my $pathtext = $c->path_text( $wit->sigil );
		my $origtext = join( ' ', @{$wit->text} );
		warn "Text differs for witness " . $wit->sigil 
			unless $pathtext eq $origtext;
		if( $wit->is_layered ) {
			$pathtext = $c->path_text( $wit->sigil.$c->ac_label );
			$origtext = join( ' ', @{$wit->layertext} );
			warn "Ante-corr text differs for witness " . $wit->sigil
				unless $pathtext eq $origtext;
		} else {
			warn "Text " . $wit->sigil . " has a layered text but is not marked as layered"
				if $wit->has_layertext;
		}
	}
	
	# Note that our ranks and common readings are set.
	$c->_graphcalc_done(1);
	# Remove redundant collation relationships.
	$c->relations->filter_collations() unless $nocollate;
}

sub _make_nodes {
    my( $collation, $row, $index, $nocollate ) = @_;
    my %unique;
    my $commonctr = 0; # Holds the number of unique readings + gaps, ex. lacunae.
    foreach my $w ( @$row ) {
        $unique{$w} = 1 if $w;
        $commonctr +=1 unless ( $w && $w eq '#LACUNA#' );
    }
    my $ctr = 1;
    foreach my $w ( keys %unique ) {
    	my $rargs = {
    		'id' => "r$index.$ctr",
    		'rank' => $index,
    		'text' => $w,
    		};
    	if( $w eq '#LACUNA#' ) {
    		$rargs->{'is_lacuna'} = 1;
    	} elsif( $commonctr == 1 ) {
    		$rargs->{'is_common'} = 1;
    	}
        my $r = $collation->add_reading( $rargs );
        $unique{$w} = $r;
        $ctr++;
    }
    # Collate this sequence of readings via a single 'collation' relationship.
    unless( $nocollate ) {
		my @rankrdgs = values %unique;
		my $collation_rel;
		while( @rankrdgs ) {
			my $r = shift @rankrdgs;
			next if $r->is_meta;
			foreach my $nr ( @rankrdgs ) {
				next if $nr->is_meta;
				if( $collation_rel ) {
					$collation->add_relationship( $r, $nr, $collation_rel );
				} else {
					$collation->add_relationship( $r, $nr, 
						{ 'type' => 'collated', 
						  'annotation' => "Parsed together for rank $index" } );
					$collation_rel = $collation->get_relationship( $r, $nr );
				}
			}
		}
	}    
    return \%unique;
}

1;

=head1 LICENSE

This package is free software and is provided "as is" without express
or implied warranty.  You can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHOR

Tara L Andrews E<lt>aurum@cpan.orgE<gt>
Commit	Line	Data
d9e873d0	1	package Text::Tradition::Parser::Tabular;
	2
	3	use strict;
	4	use warnings;
82fa4d57	5	use Text::CSV;
d9e873d0	6
	7	=head1 NAME
	8
	9	Text::Tradition::Parser::Tabular
	10
3b853983	11	=head1 SYNOPSIS
	12
	13	use Text::Tradition;
	14
	15	my $t_from_file = Text::Tradition->new(
	16	'name' => 'my text',
	17	'input' => 'Tabular',
	18	'file' => '/path/to/collation.csv',
	19	'sep_char' => ','
	20	);
	21
	22	my $t_from_string = Text::Tradition->new(
	23	'name' => 'my text',
	24	'input' => 'Tabular',
	25	'string' => $tab_separated_collation,
	26	'sep_char' => "\t",
	27	);
	28
d9e873d0	29	=head1 DESCRIPTION
	30
	31	Parser module for Text::Tradition to read an alignment table format, such as CSV.
	32
	33	=head1 METHODS
	34
e867486f	35	=head2 B<parse>( $tradition, $option_hash )
3b853983	36
	37	Takes an initialized tradition and a set of options; creates the
	38	appropriate nodes and edges on the graph, as well as the appropriate
	39	witness objects. The $option_hash must contain either a 'file' or a
	40	'string' argument with the table to be parsed; it may also contain a
	41	'sep_char' argument to specify how the fields are separated.
	42
	43	The table should have witnesses arranged in columns, with the witness sigla
	44	in the first row. Empty cells are interpreted as omissions (and thus
	45	stemmatologically relevant.) Longer lacunae in the text, to be disregarded
	46	in cladistic analysis, may be represented by filling the appropriate cells
	47	with the tag '#LACUNA#'.
	48
	49	If a witness name ends in the collation's ac_label, it will be treated as
	50	an 'ante-correction' version of the 'main' witness whose sigil it shares.
	51
	52	=begin testing
	53
	54	use Text::Tradition;
	55	binmode STDOUT, ":utf8";
	56	binmode STDERR, ":utf8";
	57	eval { no warnings; binmode $DB::OUT, ":utf8"; };
	58
	59	my $csv = 't/data/florilegium.csv';
	60	my $t = Text::Tradition->new(
	61	'name' => 'inline',
	62	'input' => 'Tabular',
	63	'file' => $csv,
	64	'sep_char' => ',',
	65	);
d9e873d0	66
3b853983	67	is( ref( $t ), 'Text::Tradition', "Parsed florilegium CSV file" );
d9e873d0	68
3b853983	69	### TODO Check these figures
3b853983	70	if( $t ) {
0e47f4f6	71	is( scalar $t->collation->readings, 311, "Collation has all readings" );
0e47f4f6	72	is( scalar $t->collation->paths, 361, "Collation has all paths" );
3b853983	73	is( scalar $t->witnesses, 13, "Collation has all witnesses" );
	74	}
	75
b0b4421a	76	# Check that we have the right witnesses
	77	my %seen_wits;
	78	map { $seen_wits{$_} = 0 } qw/ A B C D E F G H K P Q S T /;
	79	foreach my $wit ( $t->witnesses ) {
	80	$seen_wits{$wit->sigil} = 1;
	81	}
	82	is( scalar keys %seen_wits, 13, "No extra witnesses were made" );
	83	foreach my $k ( keys %seen_wits ) {
	84	ok( $seen_wits{$k}, "Witness $k still exists" );
	85	}
	86
	87	# Check that the witnesses have the right texts
	88	foreach my $wit ( $t->witnesses ) {
	89	my $origtext = join( ' ', @{$wit->text} );
	90	my $graphtext = $t->collation->path_text( $wit->sigil );
	91	is( $graphtext, $origtext, "Collation matches original for witness " . $wit->sigil );
	92	}
	93
	94	# Check that the a.c. witnesses have the right text
	95	map { $seen_wits{$_} = 0 } qw/ A B C D F G H K S /;
	96	foreach my $k ( keys %seen_wits ) {
	97	my $wit = $t->witness( $k );
	98	if( $seen_wits{$k} ) {
	99	ok( $wit->is_layered, "Witness $k got marked as layered" );
	100	ok( $wit->has_layertext, "Witness $k has an a.c. version" );
	101	my $origtext = join( ' ', @{$wit->layertext} );
	102	my $acsig = $wit->sigil . $t->collation->ac_label;
861c3e27	103	my $graphtext = $t->collation->path_text( $acsig );
b0b4421a	104	is( $graphtext, $origtext, "Collation matches original a.c. for witness $k" );
	105	} else {
	106	ok( !$wit->is_layered, "Witness $k not marked as layered" );
	107	ok( !$wit->has_layertext, "Witness $k has no a.c. version" );
	108	}
	109	}
	110
cc31ebaa	111	# Check that we only have collation relationships where we need them
cc31ebaa	112	is( scalar $t->collation->relationships, 3, "Redundant collations were removed" );
cc31ebaa	113
3b853983	114	=end testing
d9e873d0	115
	116	=cut
	117
	118	sub parse {
dfc37e38	119	my( $tradition, $opts ) = @_;
d9e873d0	120	my $c = $tradition->collation; # shorthand
97a52a67	121	my $csv_options = { 'binary' => 1 };
	122	$csv_options->{'sep_char'} = $opts->{'sep_char'} \|\| "\t";
	123	if( $csv_options->{'sep_char'} eq "\t" ) {
	124	# If it is really tab separated, nothing is an escape char.
	125	$csv_options->{'quote_char'} = undef;
bba696c6	126	$csv_options->{'escape_char'} = undef;
97a52a67	127	}
82fa4d57	128	my $csv = Text::CSV->new( $csv_options );
dfc37e38	129
d9e873d0	130	my $alignment_table;
dfc37e38	131	if( exists $opts->{'string' } ) {
	132	my @lines = split( "\n", $opts->{'string'} );
	133	foreach my $l ( @lines ) {
	134	my $status = $csv->parse( $l );
	135	if( $status ) {
	136	push( @$alignment_table, [ $csv->fields ] );
	137	} else {
	138	warn "Could not parse line $l: " . $csv->error_input;
	139	}
	140	}
	141	} elsif( exists $opts->{'file'} ) {
bb11025b	142	open( my $fh, $opts->{'file'} )
	143	or warn "Could not open input file " . $opts->{'file'};
	144	binmode( $fh, ':utf8' );
dfc37e38	145	while( my $row = $csv->getline( $fh ) ) {
dfc37e38	146	push( @$alignment_table, $row );
d9e873d0	147	}
dfc37e38	148	close $fh;
	149	} else {
	150	warn "Could not find string or file option to parse";
	151	return;
d9e873d0	152	}
dfc37e38	153
d9e873d0	154	# Set up the witnesses we find in the first line
d9e873d0	155	my @witnesses;
b0b4421a	156	my %ac_wits; # Track layered witness -> main witness mapping
82fa4d57	157	my $aclabel = $c->ac_label;
d9e873d0	158	foreach my $sigil ( @{$alignment_table->[0]} ) {
3b853983	159	if( $sigil =~ /^(.*)\Q$aclabel\E$/ ) {
82fa4d57	160	# Sanitize the sigil name to an XML name
82fa4d57	161	$sigil = $1 . '_layered';
b0b4421a	162	$ac_wits{$sigil} = $1;
3b853983	163	}
82fa4d57	164	my $wit = $tradition->add_witness(
	165	'sigil' => $sigil, 'sourcetype' => 'collation' );
	166	$wit->path( [ $c->start ] );
	167	push( @witnesses, $wit );
	168	my $aclabel = $c->ac_label;
d9e873d0	169	}
d9e873d0	170
b0b4421a	171	# Save the original witness text sequences. Have to loop back through
	172	# the witness columns after we have identified all the a.c. witnesses.
	173	foreach my $idx ( 0 .. $#{$alignment_table->[0]} ) {
	174	my @sequence = map { $_->[$idx] } @{$alignment_table};
	175	my $sigil = shift @sequence;
	176	my $is_layer = exists( $ac_wits{$sigil} );
	177	my $wit = $tradition->witness( $is_layer ? $ac_wits{$sigil} : $sigil );
	178	# Now get rid of gaps and meta-readings like #LACUNA#
	179	my @words = grep { $_ && $_ !~ /^\#.*\#$/ } @sequence;
	180	$is_layer ? $wit->layertext( \@words ) : $wit->text( \@words );
	181	}
	182
9bdf9d67	183	my $nocollate = ( scalar( @witnesses ) * scalar @$alignment_table ) > 150000;
	184	print STDERR "Tradition too big for row collation\n" if $nocollate;
	185
d9e873d0	186	# Now for the next rows, make nodes as necessary, assign their ranks, and
d9e873d0	187	# add them to the witness paths.
d9e873d0	188	foreach my $idx ( 1 .. $#{$alignment_table} ) {
d9e873d0	189	my $row = $alignment_table->[$idx];
9bdf9d67	190	my $nodes = _make_nodes( $c, $row, $idx, $nocollate );
d9e873d0	191	foreach my $w ( 0 .. $#{$row} ) {
	192	# push the appropriate node onto the appropriate witness path
	193	my $word = $row->[$w];
	194	if( $word ) {
	195	my $reading = $nodes->{$word};
	196	my $wit = $witnesses[$w];
	197	push( @{$wit->path}, $reading );
	198	} # else skip it for empty readings.
	199	}
	200	}
	201
eca16057	202	# Collapse our lacunae into a single node and
eca16057	203	# push the end node onto all paths.
d9e873d0	204	$c->end->rank( scalar @$alignment_table );
d9e873d0	205	foreach my $wit ( @witnesses ) {
eca16057	206	my $p = $wit->path;
	207	my $last_rdg = shift @$p;
	208	my $new_p = [ $last_rdg ];
	209	foreach my $rdg ( @$p ) {
83d5ac3a	210	# Omit the reading if we are in a lacuna already.
	211	next if $rdg->is_lacuna && $last_rdg->is_lacuna;
	212	# Save the reading otherwise.
	213	push( @$new_p, $rdg );
	214	$last_rdg = $rdg;
eca16057	215	}
	216	push( @$new_p, $c->end );
	217	$wit->path( $new_p );
d9e873d0	218	}
d9e873d0	219
3b853983	220	# Fold any a.c. witnesses into their main witness objects, and
	221	# delete the independent a.c. versions.
	222	foreach my $a ( keys %ac_wits ) {
b0b4421a	223	my $ac_wit = $tradition->witness( $a );
b0b4421a	224	my $main_wit = $tradition->witness( $ac_wits{$a} );
3b853983	225	next unless $main_wit;
861c3e27	226	$main_wit->is_layered(1);
3b853983	227	$main_wit->uncorrected_path( $ac_wit->path );
	228	$tradition->del_witness( $ac_wit );
	229	}
83d5ac3a	230
d9e873d0	231	# Join up the paths.
d9e873d0	232	$c->make_witness_paths;
83d5ac3a	233	# Delete our unused lacuna nodes.
	234	foreach my $rdg ( grep { $_->is_lacuna } $c->readings ) {
	235	$c->del_reading( $rdg ) unless $c->reading_witnesses( $rdg );
	236	}
861c3e27	237
	238	# Do a consistency check.
	239	foreach my $wit ( $tradition->witnesses ) {
	240	my $pathtext = $c->path_text( $wit->sigil );
	241	my $origtext = join( ' ', @{$wit->text} );
	242	warn "Text differs for witness " . $wit->sigil
	243	unless $pathtext eq $origtext;
	244	if( $wit->is_layered ) {
	245	$pathtext = $c->path_text( $wit->sigil.$c->ac_label );
	246	$origtext = join( ' ', @{$wit->layertext} );
	247	warn "Ante-corr text differs for witness " . $wit->sigil
	248	unless $pathtext eq $origtext;
	249	} else {
	250	warn "Text " . $wit->sigil . " has a layered text but is not marked as layered"
	251	if $wit->has_layertext;
	252	}
	253	}
202ccb18	254
	255	# Note that our ranks and common readings are set.
	256	$c->_graphcalc_done(1);
cc31ebaa	257	# Remove redundant collation relationships.
9bdf9d67	258	$c->relations->filter_collations() unless $nocollate;
d9e873d0	259	}
d9e873d0	260
027d819c	261	sub _make_nodes {
9bdf9d67	262	my( $collation, $row, $index, $nocollate ) = @_;
d9e873d0	263	my %unique;
15db7774	264	my $commonctr = 0; # Holds the number of unique readings + gaps, ex. lacunae.
d9e873d0	265	foreach my $w ( @$row ) {
d9e873d0	266	$unique{$w} = 1 if $w;
15db7774	267	$commonctr +=1 unless ( $w && $w eq '#LACUNA#' );
d9e873d0	268	}
	269	my $ctr = 1;
	270	foreach my $w ( keys %unique ) {
a753cc84	271	my $rargs = {
10e4b1ac	272	'id' => "r$index.$ctr",
a753cc84	273	'rank' => $index,
	274	'text' => $w,
	275	};
15db7774	276	if( $w eq '#LACUNA#' ) {
	277	$rargs->{'is_lacuna'} = 1;
	278	} elsif( $commonctr == 1 ) {
	279	$rargs->{'is_common'} = 1;
	280	}
a753cc84	281	my $r = $collation->add_reading( $rargs );
d9e873d0	282	$unique{$w} = $r;
a753cc84	283	$ctr++;
d9e873d0	284	}
bf6e338d	285	# Collate this sequence of readings via a single 'collation' relationship.
9bdf9d67	286	unless( $nocollate ) {
	287	my @rankrdgs = values %unique;
	288	my $collation_rel;
	289	while( @rankrdgs ) {
	290	my $r = shift @rankrdgs;
	291	next if $r->is_meta;
	292	foreach my $nr ( @rankrdgs ) {
	293	next if $nr->is_meta;
	294	if( $collation_rel ) {
	295	$collation->add_relationship( $r, $nr, $collation_rel );
	296	} else {
	297	$collation->add_relationship( $r, $nr,
	298	{ 'type' => 'collated',
	299	'annotation' => "Parsed together for rank $index" } );
	300	$collation_rel = $collation->get_relationship( $r, $nr );
	301	}
	302	}
	303	}
	304	}
d9e873d0	305	return \%unique;
	306	}
	307
3b853983	308	1;
	309
	310	=head1 LICENSE
	311
	312	This package is free software and is provided "as is" without express
	313	or implied warranty. You can redistribute it and/or modify it under
	314	the same terms as Perl itself.
	315
	316	=head1 AUTHOR
	317
	318	Tara L Andrews E<lt>aurum@cpan.orgE<gt>