=pod
=encoding UTF-8

pullpos.pl
 script para corregir errores de lematización por plural en los POS-taggers
 http://www.tecling.com/pullpos

    Copyright (C) 2020 - Rogelio Nazar

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.


Script para la detección de plurales

Ver artículo:

Nazar, Rogelio; Galdames, Amparo (2019). Formalización de reglas para la detección del plural en castellano en el caso de unidades no diccionarizadas. Linguamática, vol. 11, núm 2, pp. 17-32.

https://linguamatica.com/index.php/linguamatica/article/view/285/457

La ejecución de este script se da en dos etapas. A la primera lo llamamos "training",
pero consiste simplemente en la adquisición de parejas de nombres singular/plural.
En este caso se necesita un listado de formas extraido de un corpus (listado.txt),
una forma por línea. Un tabulador se interpreta como final de línea.
Generar este listado a partir de un corpus es tarea sencilla 
pero eventualmente proporcionaremos en esta página un script para esto también.

La segunda etapa es la del post-proceso de un corpus ya etiquetado.
Una vez que se tiene un modelo. En la página web de este proyecto
presentamos un modelo que viene por defecto. 

En cuanto a los etiquetadores, de momento solo hemos probado
con TreeTagger y UDPipe y esos son los que sabe leer. 
Para leer otros etiquetadores, será necesario hacer ajustes.
Cuando se producen discrepancias con el etiquetado, el script
deja un asterisco.

Este es, por ejemplo, el etiquetado de UDPipe
(el formato CONLL):

 # # newpar
 # # sent_id = 1
 # # text = EDITORIAL ¿ Son eficaces los antidepresivos ?
 # 1	EDITORIAL	editorialmente	ADV	ADV	_	4	advmod	_	_
 # 2	¿	¿	PUNCT	PUNCT	PunctSide=Ini|PunctType=Qest	4	punct	_	_
 # 3	Son	ser	AUX	AUX	Mood=Ind|Number=Plur|Person=3|Tense=Pres|VerbForm=Fin	4	cop	_	_
 # 4	eficaces	eficaz	ADJ	ADJ	Number=Plur	0	root	_	_
 # 5	los	el	DET	DET	Definite=Def|Gender=Masc|Number=Plur|PronType=Art	6	det	_	_
 # 6	antidepresivos	antidepresivo	ADJ	ADJ	Gender=Masc|Number=Plur	4	nsubj	_	_

Y este el de TreeTagger:

 #EDITORIAL	ADJ	editorial
 # ¿	FS	?
 # Son	VSfin	ser
 # eficaces	ADJ	eficaz
 # los	ART	el
 # antidepresivos	NC	antidepresivo
 # ?	FS	?

Aquí hay disponible una interfaz web que procesa texto libre
con distintos etiquetadores:

http://www.tecling.com/porcus

Modo de uso:
    perl pullpos.pl input [mode] [conll] [random]
        input: /ruta/del/fichero/a/analizar
        mode: 0 para test, 1 para train (por defecto: 0)
        conll: si es 0 se asume que el formato no es CONLL (por defecto: 1)
        random: si es 1, los resultados saldrán en orden aleatorio (por defecto: 0)
    
Para la versión 2020, contamos con la colaboración de Nicolás Acosta.

=cut
use strict;

# Estos son los parámetros de ejecución:
# Si la ejecución es "train"
my $train = $ARGV[1]; # si es 0, se ejecuta el testing mode 
# my $formas = "frecEsTenTenF5_utf8-linux.txt"; # listado de formas
my $formas = "cleanFormas2018.csv"; # listado de formas
my $umbral = 7; # umbral de frecuencia mínima del lema

# Si, en cambio, es "test"
my $modelo = "train20oct2018-19hs.csv"; # este es el modelo de ejecución (resultado del train)
my $input = $ARGV[0]; # el archivo input
my $conll = $ARGV[2]; # si el archivo está en formato CONLL
my $random = $ARGV[3]; # si queremos el listado en orden aleatorio.

if (!$input){
die "¡No se especificó un archivo para analizar!
Modo de uso:
    perl pullpos.pl input <mode> <conll> <random>
        input: /ruta/del/fichero/a/analizar
        mode: 0 para test, 1 para train (por defecto: 0)
        conll: si es 0 se asume que el formato no es CONLL (por defecto: 1)
        random: si es 1, los resultados saldrán en orden aleatorio (por defecto: 0)
";
}

# Variables por defecto
$train = 0 if (!$train | $train !~ /[0-1]/);
$conll = 1 if (!$conll | $conll !~ /[0-1]/);
$random = 0 if (!$random | $conll !~ /[0-1]/);

# Las siguientes son informaciones lingüísticas varias 
# (remitimos al artículo para mayor detalle).
my $rex = 'r?[eai]rl[oa]s?|[éá]ndo[nl][eoa]s|entamos|eramos|eremos|erimos|aremos|onamos|[nmcb][eia]mos|[eai]rnos|[ií]amos|rsel[ao]s|[aei]rles|[aei]mos'; 
my $prefijos = 'anti|auto|extra|hetero|hiper|hipo|inter|macro|meta|micro|mono|neuro|poli|post|pre|p?seudo|psico|radio|sub|super|trans'; 
my $nonplurals = '(us|[oipeas][lrxtfsd]is|[íó][dtf][aei][dnl]es)';
my $englishmorph = 'ys[ei]s|nces|tr?ics|ions|[nl]ess|ties|tions|en[td]s|[ae]cts|sters|oids|ishes|ous|ers|[csr]ies|ants|[aoe]ss';
my %cache;
my %fail; # un registro los casos fallidos
my $ch = 'A-zÁÉÍÓÚáéíóúÑñÜüçÇïÖö'; # un caracter
my $voc = 'AÁaáeEÉeéIÍiíOÓoóUÚuú'; # una vocal
my @stoplist = (
'más',
'país',
'nos',
'Es',
'tres',
'después',
'menos',
'Además',
'además',
'través',
'mientras',
'viernes',
'mes',
'lunes',
'tenemos',
'Carlos',
'jueves',
'martes',
'miércoles',
'Luis',
'seis',
'pues',
'crisis',
'hemos',
'Más',
'Tras',
'ambos',
'gracias',
'podemos',
'Mientras',
'interés',
'Después',
'atrás',
'demás',
'Dios',
'somos',
'queremos',
'Nicolás',
'Jesús',
'Nos',
'análisis',
'Tenemos',
'Cambiemos',
'tus',
'Dos',
'mas',
'Morales',
'debemos',
'Andrés',
'gas',
'lejos',
'hs',
'sabemos',
'detrás',
'Antes',
'Vamos',
'Hemos',
'Tres',
'Marcos',
'puedes',
'hacemos',
'Gracias',
'ganas',
'jamás',
'vemos',
'tienes',
'Queremos',
'Somos',
'París',
'quizás',
'Lucas',
'Reyes',
'estás',
'Matías',
'encontramos',
'Caracas',
'Londres',
'Malvinas',
'tuvimos',
'hicimos',
'vas',
'Vargas',
'podamos',
'País',
'virus',
'Pues',
'dosis',
'vos',
'Tamaulipas',
'estrés',
'venimos',
'has',
'Tomás',
'Sabemos',
'gratis',
'Lunes',
'Andes',
'Viernes',
);
my $stoplist = join '|', @stoplist;
my %transfer = (
'áceos' => 'áceo',
'aces' => 'az',
'ades' => 'ad',
'adas' => 'ada', 
'an[ae]s' => 'án',
'unes' => 'ún',
'antes' => 'ante',
'ares' => 'ar',
'arias' => 'aria',
'bles'	=> 'ble',
'cias' => 'cia',
'dos' => 'do',
'eanos' => 'eano',
'eces' => 'ez',
'ejos' => 'ejo',
'entes' => 'ente',
'eones'=> 'eón',
'eos' => 'eo',
'geas' => 'gea',
'ian[ao]s' => 'iano',
'ias' => 'ia',
'ices' => 'iz',
'íces' => 'íz',
'ic[oa]s' => 'ico',
'idades' => 'idad',
'id[oa]s' => 'ido',
'inas' => 'ina',
'ines' => 'ín',
'iones' => 'ión',
'ísim[ao]s' => 'ísimo',
'ismos' => 'ismo',
'istas' => 'ista',
'itos' => 'ito',
'ivas' => 'iva',
'iv[oa]s' => 'ivo',
'les' => 'l',
'manos' => 'mano',
'mientos' => 'miento',
'ógi[ao]s' =>  'ógico',
'oides' => 'oide',
'ólog[ao]s' => 'ólogo',
'omas' => 'oma',
'ones' => 'ón',
'or[ea]s' => 'or',
'os[ao]s' => 'oso',
'rías' => 'ría',
'rios' => 'rio',
'ríos' => 'río',
'sías' => 'sía',
'stas' => 'sta',
'stros' => 'stro',
'tías' => 'tía',
'udes' => 'ud',
'uras' => 'ura',
'úmenes' => 'umen'
);

my @rules = (
'(['.$ch.']+)s', 
'(['.$ch.']+)es',
'(['.$ch.']+['.$voc.'](i|y))e?s',
'(['.$ch.']+[A-z'.$voc.'](i|y))e?s',
'(['.$ch.']+(s|x))es',
'(['.$ch.']+[lrndzj])es',
'(['.$ch.']+[bcfghkmñpqtvwy])e?s',
'(['.$ch.']+che?)s?',
'(['.$ch.']+(?!ch)[bcdfghjklmnñpqrtvwxyz]{2})s'
);

my %forlem; # Primera lista de asociación forma-lema creada durante el entrenamiento
my %sing; # Frecuencia del singular (no son lemas en realidad, porque es el singular sin discriminar por género)
my %plural; # Frecuencia del plural
my %ground; # Almacena las razones que lo llevan a tomar una decisión

################################################################
# TRAIN
if ($train) {
	print "\nTraining mode...";
	open( my $fh, '<', $formas );
	while ( my $line = <$fh> ) {
		chomp $line;
		$line =~ s/[\/\\_\-]+//g;
		$line = lc $line;
		my ($form, $frec) = split /\t/, $line;
		next if ($form =~ /($rex)$/);
		if ($form =~ /s$/) {
			# Una primera distinción se hace en función
			# de la s final, pero luego vendrán más controles
			$plural{$form} += $frec;
		} else {
			$sing{$form} += $frec;
		}
	}
	close $fh;
	my $c;
	foreach my $form (sort keys %plural) {
		$c++;
		warn "\n$c\t$form" if ($c =~ /0000$/);
		my $lem = &rules($form);
		if ($lem) {
			$forlem{$form."\t".$lem} = $ground{$form};
		} else {
			$fail{$form}++;
		}
	}

	if (0) {
	undef $c;
	foreach my $k (sort {$forlem{$b} <=> $forlem{$a} } keys %forlem) {
		next if (!$forlem{$k});
			$c++;
			my ($form, $lem) = split /\t/, $k;
			print "\n$c\t$k\t$plural{$form}\t$sing{$lem}\t$forlem{$k}";
	}
	exit; # comentar esta línea para acceder a los elementos rechazados
	}

	undef $c;
	print "\nElementos rechazados:";
	foreach my $f (sort keys %fail) {
		$c++;
		print "\n$f";
	}

	exit;
} # end if train

################################################################

# TEST
# Esta es la del post-proceso de un corpus etiquetado

print "\nTesting mode...";

my %pos; # Etiqueta gramatical puesta por el tagger (para comprobar que sea correcta)
my %result; # Elementos reconocidos
my %oov; # Elementos no reconocidos, para dejar un aviso
my %other; # Este es un hash de dos dimensiones y agrupa todos los elementos que no 
		# son reconocidos como plurales
		# english; # Formas en inglés
		# verbos; # Formas verbales
		# noplural # Elementos no plurales

open( my $fh, '<', $modelo ) or die "\nNo puedo abrir el modelo!!! [$modelo]";
while ( my $line = <$fh> ) {
	chomp $line;
	my @f = split /\t/, $line;
	next if (!$f[2] || !$f[3]);
	$forlem{$f[2]} = $f[3];
	$sing{$f[3]} = $f[5]; #se guarda la frecuencia del singular
	$plural{$f[2]} = $f[4];# se guarda la frecuencia del plural
}
close $fh;

my %lemtag; # Lema que asigna el tagger, para compararlo con el del script
my %incorpus; # Registro del vocabulario encontrado en el mismo corpus analizado
open( $fh, '<', $input ) or die "\nNo encuentro archivo [$input]";
while ( my $line = <$fh> ) {
	next if ($line =~ /# text/);
	chomp $line;
	$line = lc $line;
	next if (!$line);
	my @f = split /\t/, $line;
	# si es el formato conll, descartamos la primera
	if ($conll) { 
		shift @f; 
	}
	$f[0] =~ s/[0-9'\(\)\*,=<>\^\{\]\[\}\.%\$\+\"]+//g; 
	next if (length($f[0]) < 4);
	if ($conll) {
		$lemtag{$f[0]} = $f[1];
		$pos{$f[0]} = $f[2];
	} else { 
		if ($f[2] eq "<unknown>") {
			$lemtag{$f[0]} = $f[0];
		} else {
			$lemtag{$f[0]} = $f[2];
		}
		$pos{$f[0]} = $f[1];
	}

	# Si las palabras están juntas por / hay que separarlas y repetir el proceso por cada una.
	my @slash = split /[\/\\\-]+/, $f[0];
	foreach my $form (@slash) {
		my $lem;
		$incorpus{$form}++;
		if ($form =~ /s$/) {
			next if ($cache{$form});
			next if ($form =~ /$stoplist/); # omitimos las palabras no plurales en @stoplist 
			$cache{$form}++; # Para que no repita las mismas operaciones
			if ($form =~ /($rex)$/) { # Elimina formas verbales
				$ground{$form} .= "[$1] ";
				$other{verbos}{$form}++;
				next;
			}
	
			if ($form =~ /($englishmorph)$/) {
				$ground{$form} .= "[$1] ";
				$other{english}{$form}++;
				next;
			}

			# Descarta casos de no plurales
			if ($form =~ /$nonplurals$/) {
				$other{noplural}{$form}++;
				$ground{$form} .= "[$1] ";
				next;
			}

			$lem = &rules($form);
			# Comprueba que el lema propuesto está documentado en corpus

			if ($lem) {
				# print "\n\n\nRules says $form -> $lem \n\n ($ground{$form})";
				&sanciona($form,$lem);
				next;
			} elsif ($forlem{$form}) {
				# print "\nEstá en el listado de parejas forma-lema ($ground{$form}).";
				$lem = &lematiza($form);
				if ($lem) {
					&sanciona($form,$lem);
					next;
				}
			} elsif ($form =~ s/^($prefijos)//) {
				my $pre = $1;
				# print "\nNo está pero reconozco un prefijo: $pre";
				$lem = &lematiza($form);
				if ($lem) {
					&sanciona($pre.$form,$pre.$lem);
					next;
				}
		  	} 

			if (!$forlem{$form}) { 
				undef $ground{$form};
				$lem = &rules($form, 1);
				if ($lem) {
					$result{$form}++;
					$forlem{$form} = $lem;
					$oov{$form} = "UNKNOWN";
				} else {
					# print "\nNo es plural: $form "; 
					$other{noplural}{$form}++;
				}
			}
		} else {
			# print "\nNo termina en s: lo cargo al hash sing";
			$sing{$form}++;
		}
	}
}
close $fh;

my $total;
print "\nForma\tLema\tError\tGround\tFrecuencia\tPOSTag\tLemTag\tDiferencia\tEval\tOOV";
my @r =  keys %result;
unless ($random) {
	 @r = sort @r;
}
foreach my $i (@r) {
	my $diferencia;
	$diferencia  = "*" if ($lemtag{$i} ne $forlem{$i});
	print "\n$i\t[$forlem{$i}]\t\t$ground{$i}\t$incorpus{$i}\t$pos{$i}\t$lemtag{$i}\t$diferencia\t\t$oov{$i}";
	$total += $incorpus{$i};
}
print "\nTotal casos corregidos: $total";


foreach my $firstkey ( sort keys %other ) {
	print "\n\n$firstkey:\n";
	my @r = keys %{$other{$firstkey}};
	unless ($random) {
		@r = sort @r;
	}
	foreach my $i (@r) {
		my $diferencia;
		$diferencia  = "*" if ($lemtag{$i} ne $i); 
		print "\n$firstkey\t$i\t$incorpus{$i}\t$ground{$i}\t$diferencia\t$lemtag{$i}";
	}
}

sub lematiza {
	my $forma = $_[0];
	return if ( $ground{$forma} =~ /Sust:/); 
	my $return;
	#print "\nEntra $forma";
	if ($forlem{$forma}) {
		$return = $forlem{$forma};
		$ground{$forma} .= "Listado ";
		if ($pos{$forma} ne "nc" && $pos{$forma} !~ /\*\*\*/) {
			my $fem = $forlem{$forma};
			$fem =~ s/o$/a/;
			if (!$sing{$fem}) {
				$pos{$forma} = "$pos{$forma} -> nc !!!"; 
				# Si tiene plural pero no femenino, es un nombre común
			}
		}
	}
	return $return;
}

sub rules {
	my $form = $_[0];
	return if ( $ground{$form} =~ /(Sust|Rules):/); 
	my $orig = $form;
	my ($lem, $rec);
	foreach my $r (sort keys %transfer) {
		my $v = $transfer{$r};
		if ( $form =~ s/$r$/$v/ ) {
			$lem = $form;
			# print "\n Sust: ($orig, $lem, $r, $v) ";
			$ground{$orig} .= "Sust: [$cache{$orig}]($orig, $lem, $r, $v) ";
			return $lem if ($_[1]);
			$rec = &decide($orig, $lem, $r);
			if ($rec) {
				return $lem;
			}
		}
	}
	if (!$lem) {
		foreach my $r (@rules) {
			if ($form =~ /$r$/) {
				$lem = $1;
				#  print "\nRule\t$r\t$lem";
				$ground{$orig} .= "Rules: ($orig, $lem, $r) ";
				$rec = &decide($orig, $lem, $r);
				if ($rec) {
					return $lem;
				}
			}
		}
	}
}

sub decide {
	my ($form, $lem, $rule) = @_;
	# Si está en el vocabulario encontrado en el mismo corpus
	# (Esto solo es útil en modo "test")
	if ($incorpus{$lem}) {
		return $lem;
	}
	return  if ($form eq $lem || !$lem || !$sing{$lem});
	my $rate =  sprintf("%.7f", $plural{$form}/$sing{$lem});
	if (
		$rate > 0.00001 
		# Controlamos que no exista una disparidad muy grande
		# entre la frecuencia del lema y de la forma.
		&& $rate < 240
	) {
		if ($ARGV[0] eq "train") {
			$ground{$form} = $rate;
		} else {
			$ground{$form} .= "Decide ($lem: $rate) ";
		}
		return $lem;
	}
}

sub femdetect {
	# Detecta formas en femenino.
	# Nos llega un supuesto lema y si termina en 'a', controlamos 
	# que no sea un adjetivo
	my ($form, $lem) = @_;
	my $origlem = $lem;
	if ($lem =~ /a$/ ) {
		#print "\n\n\n##########\nForma femenina detecteda: $forma / $forlem{$forma}";
		my $fem = $lem;
		$fem =~ s/a$//;
		my $trigger;
		my $o = $fem."o";
		if ($lem =~ /ada$/ && $sing{$o}) { 
			# Si la forma termina en 'ada' es probable que sea 'ado' 
			# (con excepciones: "empanada")
			$trigger = "0. Lema con ada pasa a o ($sing{$o}) ";
			$lem = $o;
		} elsif ((2* $sing{$o}) > $sing{$lem} || $sing{$o} > 300) {
			$trigger = "1. Lema con o [$o:$sing{$o}] > lema con a $sing{$lem} ";
			$lem = $o;
		} elsif ($sing{$fem} > $sing{$lem}) {
			#print "\nLema con o [$forma]: $sing{$forma}\n##########\n\n\n";
			$trigger = "2. Lema sin o [$o:$sing{$o}] > lema con a $sing{$lem} ";
			$lem = $fem."o";
		} else {
			$trigger = "3. Lema con a [$lem:$sing{$lem}] > $o ($sing{$o}) y ($fem) $sing{$fem} ";
		}

		if ($trigger) {
			#print "\nLema de $forma: [$forma] \n##########\n\n\n";
			if ($pos{$form} ne "adj" && $pos{$form} !~ /!!!/) {
				#print "\nCorrige etiqueta: $pos{$forma} -> adj";
				$pos{$form} = "$pos{$form} -> adj !!!";
			}
			$ground{$form} .= " $trigger ";
		}
	}
	if ($lem ne $origlem) {
		$ground{$form} .= "Forma femenina. ";
	}
	return $lem;
}

sub sanciona {
	my ($form, $lem) = @_;
	$lem = &femdetect($form, $lem);
	$result{$form}++;
	$forlem{$form} = $lem;
}