base/script/vectors.pl

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5 use feature 'say';
   6 use lib '/Users/tla/Projects/cpanmods/Text-SenseClusters-1.03/lib';
   7 use Text::SenseClusters::Simat;
   8 use Text::Tradition;
   9 use Text::WagnerFischer qw/distance/;
  10
  11 binmode STDOUT, ':utf8';
  12 binmode STDERR, ':utf8';
  13
  14 # Get our arguments
  15 my( $traditionfile, $threshold ) = @ARGV;
  16 $threshold = 0.99 unless $threshold;
  17
  18 # Load up a tradition
  19 my $t;
  20 my $m;
  21
  22 $t = Text::Tradition->new(
  23                 file => $traditionfile,
  24                 input => 'Self' );
  25 say STDERR "Parsed tradition file";
  26 my $c = $t->collation;
  27
  28 # Get the cosine similarity values
  29 my ( $matrix ) = make_matrix( $t );
  30
  31 # For each relationship in the graph, see how it compares to other node pairs
  32 # rated > $threshold
  33
  34 foreach my $pair ( $c->relationships ) {
  35         my $rel = $c->get_relationship( $pair );
  36         my( $rx, $ry ) = map { $c->reading( $_ ) } sort @$pair;
  37         next if $rx->rank > 100;
  38         next if $ry->rank > 100;
  39
  40         say STDERR "Checking relationship $rx -- $ry, of type " . $rel->type;
  41         my $matches = 0;
  42         my @matched_rels;
  43         foreach my $val ( sort { $a<=>$b } keys %{$matrix->{"$rx"}->{"$ry"}} ) {
  44                 $matches++;
  45                 foreach my $mpair ( @{$matrix->{"$rx"}->{"$ry"}->{"$val"}} ) {
  46                         my $mrel = $c->get_relationship( $mpair );
  47                         my $mreltype = $mrel ? $mrel->type : '(no relation)';
  48                         my( $mx, $my ) = map { $c->reading( $_ ) } sort @$mpair;
  49                         push( @matched_rels, sprintf( "%f: %s (%s) -- %s (%s), type %s",
  50                                 $val, $mx, $mx->text, $my, $my->text, $mreltype ) );
  51                 }
  52         }
  53         say sprintf( "Matches for %s (%s) -- %s (%s), type %s",
  54                 $rx, $rx->text, $ry, $ry->text, $rel->type );
  55         foreach ( @matched_rels ) {
  56                 say "\t$_";
  57         }
  58 }
  59
  60
  61 sub make_matrix {
  62         my @comm = $c->calculate_common_readings();
  63         my %nextcomm;
  64         my $ri = 0;
  65         foreach my $cr ( sort { $a->rank <=> $b->rank } @comm ) {
  66                 until( $cr->rank == $ri ) {
  67                         $nextcomm{$ri++} = $cr->rank;
  68                 }
  69         }
  70         until ( $ri == $c->end->rank ) {
  71                 $nextcomm{$ri++} = $c->end->rank;
  72         }
  73
  74         # Find all the relatable pairs
  75         my $grid = {};
  76         my %analyzed;
  77         my $rct = 0;
  78         foreach my $rx ( $c->readings ) {
  79                 next if $rx->rank > 100;
  80                 next if $rx->is_meta();
  81                 # Have to compare each reading with each other, so do this only once
  82                 $analyzed{"$rx"} = 1;
  83                 $rct++;
  84                 say STDERR "Looking at reading $rct ( $rx )";
  85                 foreach my $ry ( $c->readings ) {
  86                         next if $ry->rank > 100;
  87                         next if $ry->is_meta();
  88                         next if $analyzed{"$ry"};
  89
  90                         # Get their textual and graph distances from each other.
  91                         my $vector = {
  92                                 textdiff => distance( $rx->text, $ry->text ),
  93                                 rankdiff => abs( $rx->rank - $ry->rank )
  94                         };
  95                         $grid->{"$rx"}->{"$ry"} = $vector;
  96
  97                         # Do they share one or more witnesses?
  98                         my %rxwits;
  99                         my $sharewit = 0;
 100                         map { $rxwits{$_} = 1 } $rx->witnesses;
 101                         foreach my $rywit ( $ry->witnesses ) {
 102                                 if( $rxwits{$rywit} ) {
 103                                         $sharewit++;
 104                                         $vector->{'reachable'} = 1;
 105                                         last;
 106                                 }
 107                         }
 108                         $vector->{'share_witness'} = $sharewit;
 109                         # Enough with the analysis if they do share witnesses.
 110                         next if $sharewit;
 111
 112                         # Is one node reachable from the other, even if they don't share a
 113                         # witness?
 114                         $vector->{'reachable'} = $nextcomm{$rx->rank} == $nextcomm{$ry->rank} ? 0 : 1;
 115                 }
 116         }
 117
 118         # Construct the vector list
 119         # Dimensions are textdiff, rankdiff, reachable, share_witness
 120
 121         my( $i, $values ) = ( 0, 0 );
 122         my $vecindex = {};
 123         my @keys;
 124         my @lines;
 125         foreach my $rx ( keys %$grid ) {
 126                 foreach my $ry ( keys %{$grid->{$rx}} ) {
 127                         my $vec = $grid->{$rx}->{$ry};
 128                         next if $vec->{'reachable'}; # Skip all but colocations
 129                         $vecindex->{++$i} = [ $rx, $ry ];
 130                         # Note the number of keys from the first vector we look at.
 131                         unless( @keys ) {
 132                                 @keys = sort keys( %$vec );
 133                         }
 134                         # Construct the matrix.
 135                         my @fields;
 136                         foreach my $j ( 0 .. $#keys ) {
 137                                 my $v = $vec->{$keys[$j]};
 138                                 if( $v ) {
 139                                         push( @fields, $j+1, $v );
 140                                         $values++;
 141                                 }
 142                         }
 143                         push( @lines, join( " ", @fields ) );
 144                 }
 145         }
 146
 147         my $matrix .= "$i " . scalar( @keys ) . " $values\n";
 148         foreach( @lines ) {
 149                 $matrix .= "$_\n";
 150         }
 151
 152         # Open a filehandle on the matrix string we get.
 153         open( my $matrix_fh, '<', \$matrix ) or die "Could not open filehandle on string";
 154
 155         # Now send the remainder of the filehandle for calculation.
 156         my $simmatrix = Text::SenseClusters::Simat::simat( $matrix_fh );
 157
 158         # Match the returned values with the actual node pair comparisons they refer to.
 159         my $cosine_values = {};
 160         foreach my $x ( keys %$simmatrix ) {
 161                 foreach my $y ( keys %{$simmatrix->{$x}} ) {
 162                         next unless $x < $y; # skip self-comparison & duplicates
 163                         my $val = $simmatrix->{$x}->{$y};
 164                         # If the value is below our threshold of interest, skip it.
 165                         next if $val < $threshold;
 166                         # Sort the lookup of a pair alphabetically by reading ID.
 167                         my ( $r1x, $r1y ) = sort @{$vecindex->{$x}};
 168                         my ( $r2x, $r2y ) = sort @{$vecindex->{$y}};
 169                         push( @{$cosine_values->{$r1x}->{$r1y}->{$val}}, [ $r2x, $r2y ] );
 170                         push( @{$cosine_values->{$r2x}->{$r2y}->{$val}}, [ $r1x, $r1y ] );
 171                 }
 172         }
 173
 174         return $cosine_values;
 175 }