analysis/script/magnitude.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 Set::Scalar;
   9 use Text::CSV_XS;
  10 use Text::Tradition::Analysis qw/ group_variants /;
  11 use Text::Tradition::Directory;
  12 use TryCatch;
  13
  14 binmode STDOUT, ':utf8';
  15 binmode STDERR, ':utf8';
  16
  17 my( $dsn, $dbuser, $dbpass );
  18 my $filename = 'magnitude.csv';
  19 GetOptions(
  20         'dsn=s' => \$dsn,
  21         'u|user=s'   => \$dbuser,
  22         'p|pass=s' => \$dbpass,
  23         'f|file=s' => \$filename
  24 );
  25
  26 my %dbopts = ( dsn => $dsn );
  27 if( $dbuser || $dbpass ) {
  28         $dbopts{extra_args} = { user => $dbuser, password => $dbpass }
  29 }
  30
  31 my $dir = Text::Tradition::Directory->new( %dbopts );
  32 my $scope = $dir->new_scope();
  33 my $lookfor = shift @ARGV || '';
  34 my $collapse = Set::Scalar->new();
  35 if( @ARGV ) {
  36         say "Merging relationship types @ARGV";
  37         map { $collapse->insert($_) } @ARGV;
  38 }
  39
  40 my $csv = Text::CSV_XS->new( { binary => 1, quote_null => 0 } );
  41 open my $fh, ">:encoding(UTF-8)", $filename or die "$filename: $!";
  42
  43 foreach my $tinfo( $dir->traditionlist ) {
  44         next if $tinfo->{'name'} eq 'xxxxx';
  45         next if $tinfo->{'name'} =~ /158/;
  46         next if $tinfo->{'name'} =~ /Heinrichi part/;
  47         if( $lookfor ) {
  48                 next unless $tinfo->{'id'} eq $lookfor
  49                         || $tinfo->{'name'} =~ /$lookfor/;
  50         }
  51         my $tradition = $dir->lookup( $tinfo->{'id'} );
  52         say "Counting variation in tradition " . $tradition->name;
  53
  54     # Group the variants for each rank, and count the number of
  55     # reading groupings.
  56     my $lcph = Set::Scalar->new(); # placeholder for lacunae
  57     my $moved = {};
  58     my %magnitudes;
  59     my $max = 1;
  60     foreach my $rk ( 1 .. $tradition->collation->end->rank ) {
  61         my $missing = $lcph->clone();
  62         my $rankgroup = group_variants( $tradition, $rk, $missing, $moved, $collapse );
  63                 my $numr = scalar keys %$rankgroup;
  64         $numr++ if $missing->size;
  65         $max = $numr if $numr > $max;
  66                 if( exists $magnitudes{$numr} ) {
  67                         $magnitudes{$numr}++
  68                 } else {
  69                         $magnitudes{$numr} = 1;
  70         }
  71     }
  72
  73         # Write them out to CSV.
  74         my @csvalues = map { $magnitudes{$_} || 0 } 2..$max;
  75         if( $csv->combine( $tradition->name, @csvalues ) ) {
  76                 say $fh $csv->string;
  77         } else {
  78                 say "combine() failed on argument: " . $csv->error_input;
  79         }
  80 }
  81
  82 close $fh;