File Coverage

blib/lib/Lingua/PT/Actants.pm

Criterion	Covered	Total	%
statement	128	167	76.6
branch	34	44	77.2
condition	5	6	83.3
subroutine	16	20	80.0
pod	6	8	75.0
total	189	245	77.1

package Lingua::PT::Actants;
# ABSTRACT: compute verb actants for Portuguese
$Lingua::PT::Actants::VERSION = '0.03';
use strict;
use warnings;

sub new {
  my ($class, %args) = @_;
  my $data;

  # input is in conll* format
  if (exists($args{conll})) {
    $data = _conll2data($args{conll});
  }

  my $self = bless({ data=>$data }, $class);
  return $self;
}

sub _conll2data {
  my ($input) = @_;

  my @data;
  foreach my $line (split /\n/, $input) {
    next if $line =~ m/^\s*$/;

    my @l = split /\s+/, $line;
    push @data, {
        id=>$l[0], form=>$l[1], pos=>$l[3], dep=>$l[6], rule=>$l[7]
      };
  }

  return [@data];
}

sub text {
  my ($self) = @_;

  return join(' ', map {$_->{form}} @{$self->{data}});
}

sub actants {
  my ($self, %args) = @_;

  my ($cores, $ranks) = $self->acts_cores($self->{data});
  $self->{cores} = $cores;
  $self->{ranks} = $ranks;

  my @acts = $self->acts_syntagmas($cores, $self->{data});
  $self->{acts} = [@acts];

  return $self->{acts};
}

# compute actant cores
sub acts_cores {
  my ($self) = @_;
  my $data = $self->{data};

  # compute main verbs in the sentence
  my @verbs = _main_verbs($data);

  my @ranks;
  foreach my $v (@verbs) {
    my @result;
    foreach (@$data) {
      my $score = _score($_, $v);
      if ($score >= 0) {
        push @result, { token => $_, score => $score };
      }
    }

    # normalize results
    my $total = 0;
    $total += $_->{score} foreach @result;
    $_->{score} = $_->{score}/$total foreach @result;

    # sort results by score
    @result = sort {$b->{score} <=> $a->{score}} @result;

    push @ranks, { verb => $v, rank => [@result] };
  }

  my @cores;
  foreach (@ranks) {
    my ($verb, @rank) = ( $_->{verb}, @{ $_->{rank} } );

    # trim cores in rank
    my @final;
    my $ac = 0;
    foreach (@rank) {
      next if ($ac > 0.9 or $_->{score} < 0.1);

      push @final, $_;
      $ac += $_->{score};
    }

    # sort cores by token position in sentence
    @final = sort { $a->{token}->{id} <=> $b->{token}->{id} } @final;

    # set to simple list of tokens
    @final = map {$_->{token}} @final;

    push @cores, { verb => $verb, cores => [@final] };
  }

  return ([@cores], [@ranks]);
}

sub _main_verbs {
  my ($data) = @_;
  my @verbs;

  my $i;
  my @tmp;
  for ($i = 0; $i < @$data-1; $i++) {
    my ($a, $b) = ($data->[$i], $data->[$i+1]);

    unless ($a->{pos} eq 'VERB' and $b->{pos} eq 'VERB') {
      push @tmp, $a;
    }
    push @tmp, $b if ($i >= @$data);
  }

  foreach (@tmp) {
    push @verbs, $_ if (lc($_->{pos}) eq 'verb');
  }

  return @verbs;
}

sub acts_syntagmas {
  my ($self, $cores, $data) = @_;

  my @acts;
  foreach (@$cores) {
    my ($verb, @tokens) = ($_->{verb}, @{ $_->{cores} });

    my @list;
    foreach my $t (@tokens) {
      my @child = $self->_child($t);

      # remove tokens that are cores from child list
      my @tmp;
      foreach (@child) {
        push @tmp, $_ unless $self->_is_core($_);
        push @tmp, $_ if $_->{id} == $t->{id};
      }
      @child = @tmp;

      next unless @child;
      push @list, { tokens=>[@child] };
    }
    push @acts, { verb=>$verb, acts=>[@list] };
  }

  return @acts;
}

sub _score {
  my ($token, $verb) = @_;
  my $score = 0;

  $score = _score_token($token, $verb);
  my $dist = _dist($token, $verb);

  return ($dist ? $score/sqrt($dist) : 0);
}

sub _score_token {
  my ($token) = @_;

  my $score = (_score_pos($token->{pos}) + _score_rule($token->{rule})) / 2;

  return $score;
}

sub _score_pos {
  my ($pos) = @_;

  return 0.8 if ($pos =~ m/^(noun|propn|prop)$/i);
  return 0 if ($pos =~ m/^(punct)$/i);

  return 0;
}

sub _score_rule {
  my ($rule) = @_;

  return 0.8 if ($rule =~ m/^(nsubj|nsubjpass)$/i);
  return 0.6 if ($rule =~ m/^(dobj)$/i);

  return 0;
}

sub _dist {
  my ($token, $verb) = @_;

  my $dist = 0;
  $dist = $token->{id} - $verb->{id};
  $dist *= -1 if $dist < 0;

  return $dist;
}

sub _child {
  my ($self, $node) = @_;
  my @child = ();
  my $data = $self->{data};

  my $id_tree = {};
  $id_tree = _id_tree($id_tree, $node, $data);

  foreach my $id (sort keys %$id_tree) {
    foreach (@$data) {
      push @child, $_ if $_->{id} == $id;
    }
  }

  return @child;
}

sub _id_tree {
  my ($id_tree, $node, $data) = @_;

  $id_tree->{$node->{id}}++;
  foreach (@$data) {
    if ($node->{id} == $_->{dep}) {
      $id_tree = _id_tree($id_tree, $_, $data)
    }
  }

  return $id_tree;
}

sub _is_core {
  my ($self, $token) = @_;

  foreach my $i (@{$self->{cores}}) {
    foreach (@{$i->{cores}}) {
      return 1 if ($token->{id} == $_->{id});
    }
  }

  return 0;
}

sub pp_acts_cores {
  my ($self, $cores) = @_;
  $cores = $self->{cores} unless $cores;

  my $r = "# Actants syntagma cores\n";
  foreach (@$cores) {
    my ($verb, @tokens) = ($_->{verb}, @{$_->{cores}} );

    $r .= " Verb: $verb->{form}\n";
    foreach (@tokens) {
      #$r .= sprintf "  %.6f | %s\n", $_->{score}, $_->{form};
      $r .= sprintf "  + %s\n", $_->{form};
    }
  }

  return $r;
}

sub pp_acts_syntagmas {
  my ($self, $acts) = @_;
  $acts = $self->{acts} unless $acts;

  my $r = "# Actants syntagmas\n";
  foreach (@$acts) {
    my ($verb, @list) = ($_->{verb}, @{ $_->{acts} });

    $r .= " Verb: $verb->{form}\n";
    my $i = 1;
    foreach (@list) {
      $r .= sprintf "  %s: %s\n",
              "A$i",
                join(' ', map {$_->{form}} @{ $_->{tokens}});
      $i++;
    }
  }

  return $r;
}

sub pp_acts_ranks {
  my ($self, $ranks) = @_;
  $ranks = $self->{ranks} unless $ranks;

  my $r = "# Actants cores ranks\n";
  foreach (@$ranks) {
    my ($verb, @rank) = ($_->{verb}, @{$_->{rank}} );

    $r .= " Verb: $verb->{form}\n";
    foreach (@rank) {
      $r .= sprintf "  %.6f | %s\n", $_->{score}, $_->{token}->{form};
    }
  }

  return $r;
}


1;

__END__