if( ref( $arg ) eq 'Text::Tradition::Collation::Reading' ) {
$arg = $arg->id;
}
-
# Remove the reading from the graphs.
$self->sequence->delete_vertex( $arg );
$self->relations->delete_vertex( $arg );
# We only need the IDs for adding paths to the graph, not the reading
# objects themselves.
- my( $kept, $deleted ) = $self->_stringify_args( @_ );
+ my( $kept, $deleted, $combine_char ) = $self->_stringify_args( @_ );
# The kept reading should inherit the paths and the relationships
# of the deleted reading.
my @vector = ( $kept );
push( @vector, $path->[1] ) if $path->[0] eq $deleted;
unshift( @vector, $path->[0] ) if $path->[1] eq $deleted;
+ next if $vector[0] eq $vector[1]; # Don't add a self loop
my %wits = %{$self->sequence->get_edge_attributes( @$path )};
$self->sequence->add_edge( @vector );
my $fwits = $self->sequence->get_edge_attributes( @vector );
foreach my $rel ( $self->relations->edges_at( $deleted ) ) {
my @vector = ( $kept );
push( @vector, $rel->[0] eq $deleted ? $rel->[1] : $rel->[0] );
+ next if $vector[0] eq $vector[1]; # Don't add a self loop
# Is there a relationship here already? If so, keep it.
# TODO Warn about conflicting relationships
next if $self->relations->has_edge( @vector );
}
# Do the deletion deed.
+ if( $combine_char ) {
+ my $kept_obj = $self->reading( $kept );
+ my $new_text = join( $combine_char, $kept_obj->text,
+ $self->reading( $deleted )->text );
+ $kept_obj->alter_text( $new_text );
+ }
$self->del_reading( $deleted );
}
sub del_path {
my $self = shift;
+ my @args;
+ if( ref( $_[0] ) eq 'ARRAY' ) {
+ my $e = shift @_;
+ @args = ( @$e, @_ );
+ } else {
+ @args = @_;
+ }
# We only need the IDs for adding paths to the graph, not the reading
# objects themselves.
- my( $source, $target, $wit ) = $self->_stringify_args( @_ );
+ my( $source, $target, $wit ) = $self->_stringify_args( @args );
if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
- $self->sequence->del_edge_attribute( $source, $target, $wit );
+ $self->sequence->delete_edge_attribute( $source, $target, $wit );
}
unless( keys %{$self->sequence->get_edge_attributes( $source, $target )} ) {
$self->sequence->delete_edge( $source, $target );
=over 4
-=item * type - Can be one of spelling, orthographic, grammatical, meaning, repetition, transposition. The first three are only valid relationships between readings that occur at the same point in the text.
+=item * type - Can be one of spelling, orthographic, grammatical, meaning, lexical, collated, repetition, transposition. All but the last two are only valid relationships between readings that occur at the same point in the text.
=item * non_correctable - (Optional) True if the reading would not have been corrected independently.
# Check the options
if( !defined $options->{'type'} ||
- $options->{'type'} !~ /^(spelling|orthographic|grammatical|meaning|repetition|transposition)$/i ) {
+ $options->{'type'} !~ /^(spelling|orthographic|grammatical|meaning|lexical|collated|repetition|transposition)$/i ) {
my $t = $options->{'type'} ? $options->{'type'} : '';
- return( undef, "Invalid or missing type" . $options->{'type'} );
+ return( undef, "Invalid or missing type " . $options->{'type'} );
}
- if( $options->{'type'} =~ /^(spelling|orthographic|grammatical|meaning)$/ ) {
+ unless ( $options->{'type'} =~ /^(repetition|transposition)$/ ) {
$options->{'colocated'} = 1;
}
if( $self->relations->has_edge( $source, $target ) ) {
return ( undef, "Relationship already exists between these readings" );
}
- if( $options->{'colocated'} && !$self->relationship_valid( $source, $target ) ) {
+ if( !$self->relationship_valid( $source, $target, $options->{'type'} ) ) {
return ( undef, 'Relationship creates witness loop' );
}
}
sub relationship_valid {
- my( $self, $source, $target ) = @_;
- # Check that linking the source and target in a relationship won't lead
- # to a path loop for any witness. First make a lookup table of all the
- # readings related to either the source or the target.
- my @proposed_related = ( $source, $target );
- push( @proposed_related, $source->related_readings( 'colocated' ) );
- push( @proposed_related, $target->related_readings( 'colocated' ) );
- my %pr_ids;
- map { $pr_ids{ $_->id } = 1 } @proposed_related;
-
- # None of these proposed related readings should have a neighbor that
- # is also in proposed_related.
- foreach my $pr ( keys %pr_ids ) {
- foreach my $neighbor( $self->sequence->neighbors( $pr ) ) {
- return 0 if exists $pr_ids{$neighbor};
- }
- }
-
- return 1;
+ my( $self, $source, $target, $rel ) = @_;
+ if( $rel eq 'repetition' ) {
+ return 1;
+ } elsif ( $rel eq 'transposition' ) {
+ # Check that the two readings do not appear in the same witness.
+ my %seen_wits;
+ map { $seen_wits{$_} = 1 } $self->reading_witnesses( $source );
+ foreach my $w ( $self->reading_witnesses( $target ) ) {
+ return 0 if $seen_wits{$w};
+ }
+ return 1;
+ } else {
+ # Check that linking the source and target in a relationship won't lead
+ # to a path loop for any witness. First make a lookup table of all the
+ # readings related to either the source or the target.
+ my @proposed_related = ( $source, $target );
+ push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
+ push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
+ my %pr_ids;
+ map { $pr_ids{ $_ } = 1 } @proposed_related;
+
+ # None of these proposed related readings should have a neighbor that
+ # is also in proposed_related.
+ foreach my $pr ( keys %pr_ids ) {
+ foreach my $neighbor( $self->sequence->neighbors( $pr ) ) {
+ return 0 if exists $pr_ids{$neighbor};
+ }
+ }
+ return 1;
+ }
+}
+
+# Return a list of the witnesses in which the reading appears.
+sub reading_witnesses {
+ my( $self, $reading ) = @_;
+ # We need only check either the incoming or the outgoing edges; I have
+ # arbitrarily chosen "incoming".
+ my %all_witnesses;
+ foreach my $e ( $self->sequence->edges_to( $reading ) ) {
+ my $wits = $self->sequence->get_edge_attributes( @$e );
+ @all_witnesses{ keys %$wits } = 1;
+ }
+ return keys %all_witnesses;
}
sub related_readings {
print $graph->as_svg( $recalculate );
-Returns an SVG string that represents the graph. Uses GraphViz to do
-this, because Graph::Easy doesn\'t cope well with long graphs. Unless
-$recalculate is passed (and is a true value), the method will return a
-cached copy of the SVG after the first call to the method.
+Returns an SVG string that represents the graph, via as_dot and graphviz.
=cut
foreach my $reading ( $self->readings ) {
# Need not output nodes without separate labels
next if $reading->id eq $reading->text;
- $dot .= sprintf( "\t\"%s\" [ label=\"%s\" ];\n", $reading->id, $reading->text );
+ my $label = $reading->text;
+ $label =~ s/\"/\\\"/g;
+ $dot .= sprintf( "\t\"%s\" [ label=\"%s\" ];\n", $reading->id, $label );
}
# TODO do something sensible for relationships
foreach my $edge ( @edges ) {
my %variables = ( 'color' => '#000000',
'fontcolor' => '#000000',
- 'label' => join( ', ', $self->path_witnesses( $edge ) ),
+ 'label' => join( ', ', $self->path_display_label( $edge ) ),
);
my $varopts = join( ', ', map { $_.'="'.$variables{$_}.'"' } sort keys %variables );
$dot .= sprintf( "\t\"%s\" -> \"%s\" [ %s ];\n",
return sort @wits;
}
+sub path_display_label {
+ my( $self, $edge ) = @_;
+ my @wits = $self->path_witnesses( $edge );
+ my $maj = scalar( $self->tradition->witnesses ) * 0.6;
+ if( scalar @wits > $maj ) {
+ return 'majority';
+ } else {
+ return join( ', ', @wits );
+ }
+}
+
+
=item B<as_graphml>
print $graph->as_graphml( $recalculate )
# Add the data keys for the graph
my %graph_data_keys;
my $gdi = 0;
- my @graph_attributes = qw/ wit_list_separator baselabel linear ac_label /;
+ my @graph_attributes = qw/ version wit_list_separator baselabel linear ac_label /;
foreach my $datum ( @graph_attributes ) {
$graph_data_keys{$datum} = 'dg'.$gdi++;
my $key = $root->addNewChild( $graphml_ns, 'key' );
my $ndi = 0;
my %node_data = (
id => 'string',
- reading => 'string',
+ text => 'string',
rank => 'string',
is_start => 'boolean',
is_end => 'boolean',
# Collation attribute data
foreach my $datum ( @graph_attributes ) {
- _add_graphml_data( $graph, $graph_data_keys{$datum}, $self->$datum );
+ my $value = $datum eq 'version' ? '2.0' : $self->$datum;
+ _add_graphml_data( $graph, $graph_data_keys{$datum}, $value );
}
my $node_ctr = 0;
my $node_xmlid = 'n' . $node_ctr++;
$node_hash{ $n->id } = $node_xmlid;
$node_el->setAttribute( 'id', $node_xmlid );
- _add_graphml_data( $node_el, $node_data_keys{'id'}, $n->id );
- _add_graphml_data( $node_el, $node_data_keys{'reading'}, $n->text );
- _add_graphml_data( $node_el, $node_data_keys{'rank'}, $n->rank )
- if $n->has_rank;
+ foreach my $d ( keys %node_data ) {
+ my $nval = $n->$d;
+ _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
+ if defined $nval;
+ }
}
# Add the path edges
$seen{$n->id} = 1;
my $next = $self->next_reading( $n, $witness, $backup );
- $DB::single = 1 if $next->id eq $end->id;
unless( $next ) {
warn "Did not find any path for $witness from reading " . $n->id;
last;
sub make_witness_paths {
my( $self ) = @_;
foreach my $wit ( $self->tradition->witnesses ) {
- print STDERR "Making path for " . $wit->sigil . "\n";
+ # print STDERR "Making path for " . $wit->sigil . "\n";
$self->make_witness_path( $wit );
}
}
foreach my $n ( $self->sequence->successors( $r->id ) ) {
my( $tfrom, $tto ) = ( $rel_containers{$r->id},
$rel_containers{$n} );
+ $DB::single = 1 unless $tfrom && $tto;
$topo_graph->add_edge( $tfrom, $tto );
}
}
my $key = $rdg->rank . "||" . $rdg->text;
if( exists $unique_rank_rdg{$key} ) {
# Combine!
- print STDERR "Combining readings at same rank: $key\n";
+ # print STDERR "Combining readings at same rank: $key\n";
$self->merge_readings( $unique_rank_rdg{$key}, $rdg );
} else {
$unique_rank_rdg{$key} = $rdg;
=over
-=item * Rationalize edge classes
-
-=item * Port the internal graph from Graph::Easy to Graph
+=item * Think about making Relationship objects again
=back
projects / scpubgit/stemmatology.git / blobdiff