analysis/script/analyze.pl

   1 #!/usr/bin/env perl
   2
   3 use feature 'say';
   4 use lib 'lib';
   5 use strict;
   6 use warnings;
   7 use Getopt::Long;
   8 use Text::CSV_XS;
   9 use Text::Tradition::Analysis qw/ run_analysis /;
  10 use Text::Tradition::Directory;
  11 use TryCatch;
  12
  13 binmode STDOUT, ':utf8';
  14 binmode STDERR, ':utf8';
  15
  16 my( $dsn, $dbuser, $dbpass );
  17 my $filename = 'analysis.csv';
  18 GetOptions(
  19         'dsn=s' => \$dsn,
  20         'u|user=s'   => \$dbuser,
  21         'p|pass=s' => \$dbpass,
  22         'f|file=s' => \$filename
  23 );
  24
  25 my %dbopts = ( dsn => $dsn );
  26 if( $dbuser || $dbpass ) {
  27         $dbopts{extra_args} = { user => $dbuser, password => $dbpass }
  28 }
  29
  30 my $dir = Text::Tradition::Directory->new( %dbopts );
  31 my $scope = $dir->new_scope();
  32 my $lookfor = shift @ARGV || '';
  33 my %collapse;
  34 if( @ARGV ) {
  35         say "Merging relationship types @ARGV";
  36         map { $collapse{$_} = 1 } @ARGV;
  37 }
  38
  39 my @relation_types = grep { !$collapse{$_} }
  40         qw/ orthographic spelling grammatical lexical transposition repetition
  41             uncertain other addition deletion wordsimilar unknown source /;
  42
  43 my @resultfields = qw/
  44         text_name loc_total loc_singleton multiparent loc_totalvariant loc_genealogical loc_genvariant
  45         loc_conflict loc_conflictvariant loc_reverted loc_revertvariant /;
  46 map { push( @resultfields, "gen_$_", "con_$_", "rev_$_" ) } @relation_types;
  47
  48 my $csv = Text::CSV_XS->new( { binary => 1, quote_null => 0 } );
  49 open my $fh, ">:encoding(UTF-8)", $filename or die "$filename: $!";
  50 if( $csv->combine( @resultfields ) ) {
  51         say $fh $csv->string;
  52 } else {
  53         say "combine() failed on argument: " . $csv->error_input;
  54 }
  55
  56 foreach my $tinfo( $dir->traditionlist ) {
  57         next if $tinfo->{'name'} eq 'xxxxx';
  58         next if $tinfo->{'name'} =~ /158/;
  59         next if $tinfo->{'name'} =~ /Heinrichi part/;
  60         if( $lookfor ) {
  61                 next unless $tinfo->{'id'} eq $lookfor
  62                         || $tinfo->{'name'} =~ /$lookfor/;
  63         }
  64         my $tradition = $dir->lookup( $tinfo->{'id'} );
  65         next unless $tradition->stemma_count;
  66         say "Analyzing tradition " . $tradition->name;
  67         ## HACK
  68         my $MAXRANK;
  69         if( $tradition->name =~ /Chronicle/ ) {
  70                 $MAXRANK = $tradition->collation->reading('L1545')->rank;
  71         }
  72         my %datahash;
  73         # Initialize everything with zeroes
  74         map { $datahash{$_} = 0 } @resultfields;
  75         # Put in the real text ID and name
  76         $datahash{text_id} = $tinfo->{'id'};
  77         $datahash{text_name} = $tradition->name;
  78
  79         # Run the analysis for each row in @rows
  80         my %opts = (
  81                 exclude_type1 => 1,
  82                 merge_types => [ 'punctuation' ] );
  83         if( keys %collapse ) {
  84                 push( @{$opts{merge_types}}, keys %collapse );
  85         }
  86
  87         my $result;
  88         try {
  89                 $result = run_analysis( $tradition, %opts );
  90         } catch {
  91                 say "Analysis run failed on tradition " . $tradition->name . ": @_";
  92                 next;
  93         }
  94         $datahash{loc_total} = $result->{variant_count};
  95         $datahash{multiparent} = 0;
  96         #$datahash{loc_genealogical} = $result->{genealogical_count};
  97         #$datahash{loc_conflictvariant} = $result->{conflict_count};
  98         #$datahash{loc_revertvariant} = $result->{reversion_count};
  99         # Get the totals by location and by variant as we go.
 100         my $totalvariant = 0;
 101         my $singleton = 0;
 102         my $genloc = 0;
 103         my $genvariant = 0;
 104         my $conflictloc = 0;
 105         my $conflictvariant = 0;
 106         my $revertloc = 0;
 107         my $revertvariant = 0;
 108         my $msgd; # for the HACK
 109         my @unknown;
 110         foreach my $loc ( @{$result->{variants}} ) {
 111                 # A transition is the relationship type between parent and child.
 112                 # Find each genealogical transition and get the relationship type (if any)
 113                 # Find each non-genealogical transition and get the relationship type (if any)
 114                 my( $loc_conflict, $loc_reversion );
 115                 if( exists $loc->{unsolved} ) {
 116                         # Not solved; remove it from the total.
 117                         say "Skipping unsolved location at " . $loc->{id};
 118                         $datahash{loc_total}--;
 119                         next;
 120                 } elsif( $MAXRANK && $loc->{id} > $MAXRANK ) {
 121                         # HACK until Chronicle tagging is done
 122                         say "Skipping ranks above $MAXRANK"
 123                                 unless $msgd;
 124                         $msgd = 1;
 125                         next;
 126                 }
 127                 foreach my $rdghash( @{$loc->{readings}} ) {
 128                         # Weed out singletons
 129                         $totalvariant++;
 130                         my @roots = @{$rdghash->{independent_occurrence}};
 131                         if( @roots == 1 && !$rdghash->{'followed'} && !$rdghash->{'not_followed'}
 132                                 && !$rdghash->{'follow_unknown'} ) {
 133                                 $singleton++;
 134                                 next;
 135                         }
 136                         my $rdg = $tradition->collation->reading( $rdghash->{readingid} );
 137                         my $type;
 138                         if( $rdghash->{'is_conflict'} ) {
 139                                 $type = 'conflict';
 140                                 $loc_conflict = 1;
 141                                 $conflictvariant++;
 142                         } elsif( $rdghash->{'is_reverted'} ) {
 143                                 $type = 'reverted';
 144                                 $loc_reversion = 1;
 145                                 $revertvariant++;
 146                         } elsif( @roots == 1 ) {
 147                                 $type = 'genealogical';
 148                                 $genvariant++;
 149                         } else {
 150                                 warn "Reading $rdg neither conflict, genealogical, nor reverted. What?";
 151                                 $type = 'ERROR';
 152                         }
 153                         my $typekey = substr( $type, 0, 3 ) . '_';
 154
 155                         # Add relation stats for reading parents. If the reading is reverted,
 156                         # the 'parent' is the reversion parent rather than the parents of the
 157                         # reading source.
 158                         my $phash = $type eq 'reverted'
 159                                 ? $rdghash->{'reversion_parents'} : $rdghash->{'source_parents'};
 160                         _add_reading_relations( $rdghash->{'readingid'}, $loc->{'id'}, $rdg,
 161                                 $type, $phash, \%datahash, \@unknown );
 162                 }
 163                 if( $loc_conflict ) {
 164                         $conflictloc++;
 165                 } elsif( $loc_reversion ) {
 166                         $revertloc++;
 167                 } else {
 168                         $genloc++;
 169                 }
 170         }
 171
 172         # Add in the sums for the whole location
 173         $datahash{loc_totalvariant} = $totalvariant;
 174         $datahash{loc_genealogical} = $genloc;
 175         $datahash{loc_genvariant} = $genvariant;
 176         $datahash{loc_conflict} = $conflictloc;
 177         $datahash{loc_conflictvariant} = $conflictvariant;
 178         $datahash{loc_reverted} = $revertloc;
 179         $datahash{loc_revertvariant} = $revertvariant;
 180         $datahash{loc_singleton} = $singleton;
 181         $datahash{percent_genealogical} = $datahash{loc_genealogical} / $datahash{loc_total};
 182         $datahash{percent_genvariant} = $genvariant / $totalvariant;
 183         $datahash{percent_genorrevert} = ( $genvariant + $datahash{loc_revertvariant} ) / $totalvariant;
 184
 185         # Write them out to CSV.
 186         my @csvalues = map { $datahash{$_} } @resultfields;
 187         if( $csv->combine( @csvalues ) ) {
 188                 say $fh $csv->string;
 189         } else {
 190                 say "combine() failed on argument: " . $csv->error_input;
 191         }
 192         map { say STDERR sprintf( "Unknown transition %s -> %s (%s) :%s", @$_ ) } @unknown;
 193 }
 194
 195 close $fh;
 196
 197 sub _add_reading_relations {
 198         my( $rid, $rank, $robj, $type, $parenthash, $datahash, $unknown ) = @_;
 199         my @kp = keys ( %$parenthash );
 200         unless( @kp ) {
 201                 _increment_typekey( $datahash, $type, 'source' );
 202                 return;
 203         }
 204         if( @kp > 1 ) {
 205                 $datahash->{multiparent} = @kp - 1;
 206         }
 207         foreach my $p ( @kp ) {
 208                 my $pdata = $parenthash->{$p};
 209                 my $relation;
 210                 if( $pdata->{relation} ) {
 211                         $relation = $pdata->{relation}->{transposed}
 212                                 ? 'transposition' : $pdata->{relation}->{type};
 213                 } else {
 214                         $relation = 'unknown';
 215                         if( !$robj ) {
 216                                 say "Unknown relation on missing reading object $rid at rank $rank";
 217                         } elsif( !$pdata ) {
 218                                 say "Unknown relation on missing parent object for $rid at rank $rank";
 219                         } else {
 220                                 push( @$unknown, [ $pdata->{label}, $robj->id, $robj->text, $type ] );
 221                         }
 222                 }
 223                 _increment_typekey( $datahash, $type, $relation );
 224         }
 225 }
 226
 227 sub _increment_typekey {
 228         my( $datahash, $type, $relation ) = @_;
 229         my $typekey = substr( $type, 0, 3 ) . "_$relation";
 230         unless( exists $datahash->{$typekey} ) {
 231                 $DB::single = 1;
 232                 warn "No field for $typekey";
 233         }
 234         $datahash->{$typekey}++;
 235 #       # TODO distinguish parent-bad vs. rdg-bad
 236 #       if( $robj && $robj->grammar_invalid ) {
 237 #               $datahash->{$typekey.'_ungramm'} = 1;
 238 #       } elsif( $robj && $robj->is_nonsense ) {
 239 #               $datahash->{$typekey.'_nonsense'} = 1;
 240 #       }
 241 }