File Coverage

blib/lib/Lingua/FR/Ladl/Table.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Lingua::FR::Ladl::Table;

use warnings;
use strict;
use English;

use version; our $VERSION = qv('0.0.1');

use Carp;

use Readonly;
use List::Util qw(max first);
use List::MoreUtils qw(all);


use Lingua::FR::Ladl::Exceptions;
use Lingua::FR::Ladl::Parametrizer;
use Lingua::FR::Ladl::Util;

use Class::Std;

{
  Readonly my %is_implemented_format => ( xls => \&_load_xls,
                                          xml => \&_load_gnumeric_xml );

  my %name_of : ATTR( :default('none') :name);
  my %table_of : ATTR;   # hash of hashes to hold the table data in a perl data structure
  my %maxCol_of : ATTR( :default(0) :name);
  my %maxRow_of : ATTR( :default(0) :name);
  my %verbCol_of : ATTR;
  my %verbs_of : ATTR;
  my %colTypes_of : ATTR;
  my %is_tildaRow_of : ATTR;
  my %headers_of : ATTR;
  my %parameters_of : ATTR( :set :get ); # customization parameters

  ############# Utility subroutines #################################################################

  sub _find_out_verbCol {
    my ($id) = @_;

    my $name = $name_of{$id};

    my $verbCol = first { $table_of{$id}->{0}->{$_} =~ m{\b$name\b} } (keys %{$table_of{$id}->{0}});

    if ($verbCol) {
      $verbCol_of{$id} = $verbCol;
      return $verbCol_of{$id};
    } else {
      carp "Couldn't find out verb column: no column with column header $name\n";
      return;
    }

  }

  sub _check_row {
    my ($table, $row, $message) = @_;

    croak "$row must be greater 0\n" unless $row;

    my $id = ident $table;
    X::NoTableData->throw(
                          message => $message,
                          table => $table,
                         ) unless $table_of{$id};

    croak "$row must be less or equal $maxRow_of{$id}\n" if $row > $maxRow_of{$id};

    return;

  }

    sub _check_col {
    my ($table, $col, $message) = @_;

    croak "$col must be greater 0\n" unless $col;

    my $id = ident $table;
    X::NoTableData->throw(
                          message => $message,
                          table => $table,
                         ) unless $table_of{$id};

    croak "$col must be less or equal $maxCol_of{$id}\n" if $col > $maxCol_of{$id};

    return;

  }

  sub _load_xls {
    my ($file_name) = @_;

    my $table_ref = {};

    eval { use Spreadsheet::ParseExcel; };
    if ($EVAL_ERROR) {
      croak "Can't load table data from excel file $file_name: Spreadsheed::ParseExcel not installed";
    }

    my $excel = Spreadsheet::ParseExcel::Workbook->Parse($file_name) or
      croak "Error parsing $file_name: Spreadsheet::ParseExcel returned undef\n";
    my $sheet = $excel->{Worksheet}->[0];
    $sheet->{MaxRow} ||= $sheet->{MinRow};
    unless ($sheet->{MaxRow}) {
      croak "Couldn't load table data: Spreadsheet::ParseExcel returned 0 max row when parsing $file_name\n";
    }
    foreach my $row ($sheet->{MinRow} .. $sheet->{MaxRow}) {
      $sheet->{MaxCol} ||= $sheet->{MinCol};
      foreach my $col ($sheet->{MinCol} ..  $sheet->{MaxCol}) {
        my $cell = $sheet->{Cells}[$row][$col];
        if ($cell) {
          $table_ref->{$row}->{$col} = $cell->{Val};
        }
      }
    }
    return ($table_ref, $sheet->{MaxRow}, $sheet->{MaxCol});
  }


  sub _load_gnumeric_xml {
    my ($file_name) = @_;

    my $table_ref = {};

    eval { use XML::LibXML; };
    if ($EVAL_ERROR) {
      croak "Can't load table data from xml file $file_name: XML::LibXML not installed\n";
    }


    my $parser = XML::LibXML->new();
    $parser->keep_blanks(0);
    my $table_doc = $parser->parse_file($file_name);
    my @cells = $table_doc->findnodes("//gmr:Cell");
    foreach my $cell (@cells) {
      my $row = $cell->getAttribute('Row');
      my $col = $cell->getAttribute('Col');
      $table_ref->{$row}->{$col}=$cell->textContent();
    }
    my @maxRowCells = $table_doc->findnodes("//gmr:MaxRow");
    my $maxRow = $maxRowCells[0]->textContent();

    my @column_nbrs = map { $_->getValue() } $table_doc->findnodes('//gmr:Cell/@Col');

    my $maxCol = max @column_nbrs;

    return ($table_ref, $maxRow, $maxCol);

  }

  ############ Methods ###################################################################

  sub BUILD {
    my ($self, $id, $arg_ref) = @_;

    # parametrize with new default parametrizer
    my $param = Lingua::FR::Ladl::Parametrizer->new();
    $parameters_of{$id} = $param;
  }

  sub load {
    my ($self, $arg_ref) = @_;
    my $format = $arg_ref->{format};
    my $file_name = $arg_ref->{file};
    my $id = ident $self;

    unless ($is_implemented_format{$format}) {
      croak 'Format must be one of '.join(', ', keys %is_implemented_format).", not $format\n";
    }

=for Rationale:
     We set a default table name, inferred from the file name.
     The table name is needed for inferring the verb column
     which is the header of the verb column.
     However the table name can be also set manually.
     The get_verb_column() method won't work if the table name is
     not set correctly.

=cut

    $self->set_name(_Name::from_file_name($file_name));

    ($table_of{$id}, $maxRow_of{$id}, $maxCol_of{$id}) = $is_implemented_format{$format}->($file_name);

    return;
  }


=for Rationale
     The header line is line number 0 in the table
     This sub returns a hash with the headers as keys and the columns as values.

=cut

  sub get_headers {
    my ($self) = @_;
    my $id = ident $self;

    if ($headers_of{$id}) {
      return $headers_of{$id};
    }

    X::NoTableData->throw(
                          message => "Could not get table headers:\n",
                          table => $self)
        unless $table_of{$id};

    foreach my $col_num (0..$maxCol_of{$id}) {
      if (exists $table_of{$id}->{0}->{$col_num}) {
        my $header = $table_of{$id}->{0}->{$col_num};
        $headers_of{$id}->{$header} = $col_num;
      } else {
        $headers_of{$col_num} = $col_num;
      }
    }

    return $headers_of{$id};
  }

  sub get_value_at {
    my ($self, $row, $col) = @_;
    my $id = ident($self);

    _check_row($self, $row, "Can't get value at $row, $col:");
    _check_col($self, $col, "Can't get value at $row, $col:");

    return $table_of{$id}->{$row}->{$col};
  }

  sub get_col_for_header {
    my ($self, $header) = @_;
    my $id = ident($self);

    X::NoTableData->throw(
                          message => "Couldn't find out col for header:\n",
                          table => $self )
        unless $table_of{$id};

    my $col_for_headers = $self->get_headers();
    if (exists($col_for_headers->{$header})) {
      return $col_for_headers->{$header};
    } else {
      return;
    }

  }

  sub get_header_for_col {
    my ($self, $col) = @_;
    my $id = ident($self);

    _check_col($self, $col, "Can't get header for $col:");

    my $header = $table_of{$id}->{0}->{$col};
    my $empty_string_mark = $self->get_parameters()->get_empty_string_mark();
    $header =~ s{$empty_string_mark}{};
    return $header;
  }


=for Rationale:
     we determine the verb column as the header column with the table name
     this is an empirical observation, it may fail!

=cut

  sub get_verb_column {
    my ($self) = @_;
    my $id = ident $self;

    if ($verbCol_of{$id}) {
      return $verbCol_of{$id};
    } else {
      X::NoTableData->throw(
                            message => "Couldn't find out verb column:\n",
                            table => $self )
          unless $table_of{$id};
      return _find_out_verbCol($id);
    }
  }



  sub get_verbs {
    my ($self) = @_;
    my $id = ident $self;

    if ($verbs_of{$id}) {
      return @{$verbs_of{$id}};
    } else {
      croak "Need table to calculate verbs\n" unless $table_of{$id};
      my $verbCol = $verbCol_of{$id} or $self->get_verb_column();
      my $maxRow = $maxRow_of{$id} or $self->get_maxRow();
      croak "Max row must be greater 0" unless $maxRow;
      $verbs_of{$id} = [ map { $table_of{$id}->{$_}->{$verbCol} } 1 .. $maxRow ];
      return @{$verbs_of{$id}};
    }
  }


=for Rationale:
     the particle column is the column before the verb column

=cut

  sub get_particle_column {
    my ($self) = @_;
    my $id = ident $self;

    my $verbCol = $verbCol_of{$id} or $self->get_verb_column();

    return $verbCol - 1;

  }

=for Rationale:
     the example column is the last column

=cut

  sub get_example_column {
    my ($self) = @_;
    my $id = ident $self;

    if ($maxCol_of{$id}) {
      return $maxCol_of{$id};
    } else {
      X::NoTableData->throw(
                            message => "Max column is 0!\n",
                            table => $self,
                           );
      return;
    }
  }

=for Rationale:
  We try to determine the data type of a specific column
  first we read a sample row (other than 0 which is the header row)
  if the content of a given column is other than '+' '-' '~' we
  presume that this column is supposed to contain text data,
  else the possible values are '+', '-', '~'
  Returns a hash reference with the column index as keys and either the string `+-~' or the string `text' as values.

=cut

  sub get_column_types {
    my ($self) = @_;
    my $id = ident $self;

    if ($colTypes_of{$id}) {
      return $colTypes_of{$id};
    } else {

      X::NoTableData->throw(
                            message => "Couldn't calculate column types:\n",
                            table => $self,
                           )
          unless $table_of{$id};

      while ( my ($col_num, $col_val) = each %{$table_of{$id}->{1}} ) {
        if ( $col_val =~ m{\A \s* [+-~] \s* \z}xms ) {
          $colTypes_of{$id}->{$col_num} = '+-~';
        } else {
          $colTypes_of{$id}->{$col_num} = 'text';
        }
      }
      return $colTypes_of{$id};
    }
  }

  sub get_column_type_for_col {
    my ($self, $col) = @_;
    my $id = ident $self;

    _check_col($self, $col, "Can't get column type for column $col:");

    my $colTypes = $colTypes_of{$id} ? $colTypes_of{$id} : $self->get_column_types();

    return $colTypes->{$col};
  }



=for Rationale:
     A row of the table is a tilda row when all the columns of `+-~'
     type contain a `~'. This means, the table doesn't say anything about this verb (usage).
     The row is identified by number.

=cut

  sub is_tilda_row {
    my ($self, $row) = @_;
    my $id = ident $self;

    if ($is_tildaRow_of{$id}) {
      return $is_tildaRow_of{$id};
    }

    my $err_msg = "Can't check if tilda row: \n";
    _check_row($self, $row, $err_msg);

    my $col_types = $self->get_column_types();

    $is_tildaRow_of{$id} = all { $table_of{$id}->{$row}->{$_} eq '~' } grep { $col_types->{$_} eq '+-~' } keys %{$col_types};

    return $is_tildaRow_of{$id};
  }

  sub get_verb_for_row {

    my ($self, $row) = @_;
    my $id = ident $self;

    my $err_msg = "Can't get verb of row:\n";
    _check_row($self, $row, $err_msg);

    return $table_of{$id}->{$row}->{$verbCol_of{$id}};
  }

  sub get_rows_for_verb {
    my ($self, $verb) = @_;
    my $id = ident $self;

    croak "No verb\n" unless $verb;

    X::NoTableData->throw(
                          message => "Couldn't get rows of verb: $verb:\n",
                          table => $self,
                         ) unless $table_of{$id};

    my $verbCol = $verbCol_of{$id};
    my @rows = grep { $table_of{$id}->{$_}->{$verbCol} =~ m{\b$verb\b} } 1 .. $maxRow_of{$id};

    return (@rows);
  }


=for Rationale:
     A column may be of type `text' or `+-~'.
     - A `text' column of a row is set if it's different from the `Empty mark', which in this case is .
     - A `+-~' column of a row is set if it's `+'.
     The `empty string mark' can be set via the Parametrizer Object

=cut


  sub is_column_set {
    my ($self, $row, $col) = @_;

    _check_row($self, $row, "Can't test if column is set:\n");
    my $col_types = $self->get_column_types();
    my $empty_mark = $self->get_parameters()->get_empty_string_mark();
    my $re = qr($empty_mark);

    if ($col_types->{$col} eq 'text') {
      $table_of{ident $self}->{$row}->{$col} =~ m{$re} ? return 0 : return 1;
    } else {
      $table_of{ident $self}->{$row}->{$col} =~ m{[+]} ? return 1 : return 0;
    }
  }

  sub has_verb {
    my ($self, $verb) = @_;
    my $id = ident($self);

    croak "Can't check on empty verb\n" unless $verb;

    my $verbCol = $self->get_verb_column();

    return grep { m{\b$verb\b} } map { $table_of{$id}->{$_}->{$verbCol}  } 1 .. $maxCol_of{$id};
  }

  sub has_verb_matching {
    my ($self, $match) = @_; # match is supposed to be a pattern: either a string or a qr//
    my $id = ident($self);

    croak "Won't check on empty match\n" unless $match;

    my $verbCol = $self->get_verb_column();

    return grep { m{$match} } map { $table_of{$id}->{$_}->{$verbCol}  } 1 .. $maxCol_of{$id};
  }

  sub create_db_table {
    my ($self, $arg_ref) = @_;
    my $id = ident($self);

    X::NoTableData->throw(
                          message => "Can't create DB handle:\n",
                          table => $self,
                         ) unless $table_of{$id};

    use DBI;
    my $dbh=DBI->connect('dbi:AnyData(RaiseError=>1):');

    my @column_names;
    if (not ($arg_ref) or $arg_ref->{col_names} eq 'col_numbers') {
      @column_names = map { "col_$_" } 0 .. $maxCol_of{$id};
    } else {
      @column_names =
        map {
          my $header = $table_of{$id}->{0}->{$_};
          if (not $header) {
            $header = "col_$_";
          }
          $header =~ m{\A \p{Alphabetic} }x ? $header : "col_$header";
        } 0 .. $maxCol_of{$id};
      my $verbCol = $verbCol_of{$id} or $self->get_verb_column();
      $column_names[$verbCol] = 'verb';
      $column_names[$verbCol-1] = 'particle';
      $column_names[$maxCol_of{$id}] = 'example';
    }

    my $empty_string_mark = $parameters_of{$id}->get_empty_string_mark();
    my $db_array_ref = [
                        [@column_names],
                        map {
                          my $row = $_;
                          [
                           map {
                             my $col_value = $table_of{$id}->{$row}->{$_};
                             $col_value =~ s{$empty_string_mark}{};
                             "$col_value";
                           } 0 .. $maxCol_of{$id}
                          ];
                        } 1 .. $maxRow_of{$id}
                       ];

    $dbh->func( "table_$name_of{$id}",
                'ARRAY',
                $db_array_ref,
                'ad_import');

    return $dbh;
  }

}

1; # Magic true value required at end of module
__END__