diff --git a/IRC3sp/IRC3sp.pl b/IRC3sp/IRC3sp.pl new file mode 100755 index 0000000..12b26c7 --- /dev/null +++ b/IRC3sp/IRC3sp.pl @@ -0,0 +1,738 @@ +#!/usr/bin/perl + + +# Déclaration des pragmas +use strict; +use utf8; +use open qw/:std :utf8/; + + +# Appel des modules externes +use Encode qw(is_utf8); +use Getopt::Long; + +# Recherche du nom du programme +my ($programme) = $0 =~ m|^(?:.*/)?(.+)|; +my $usage = "Usage : \n" . + " $programme -t table -r répertoire [ -e extension ]* [ -s fichier_sortie ] [ -l log ] [ -cq ]\n" . + " $programme -t table -f fichier_entrée [ -s fichier_sortie ] [ -l log ] [ -cq ]\n" . + " $programme -t table [ -l log ] [ -cq ]\n" . + " $programme -h\n\n"; + +my $version = "1.3.1"; +my $dateModif = "12 Mars 2019"; + +my @table = (); +my %genre = (); +my %liste = (); +my %pref = (); +my %str = (); + +# Initialisation des variables globales +# nécessaires à la lecture des options +my $aide = 0; +my $casse = 0; +my $fichier = ""; +my $log = ""; +my $quiet = 0; +my $repertoire = ""; +my $sortie = ""; +my $table = ""; +my @extensions = (); + +eval { + $SIG{__WARN__} = sub {usage(1);}; + GetOptions( + "casse" => \$casse, + "extension=s" => \@extensions, + "fichier=s" => \$fichier, + "help" => \$aide, + "log=s" => \$log, + "quiet" => \$quiet, + "repertoire=s" => \$repertoire, + "sortie=s" => \$sortie, + "table=s" => \$table, + ); + }; +$SIG{__WARN__} = sub {warn $_[0];}; + +if ( $aide ) { + print "\nProgramme : \n \"$programme\", version $version ($dateModif)\n"; + print " Adaptation du script Perl “IRC3.pl” permettant la reconnaissance et l’extraction \n"; + print " dans un corpus de textes de noms scientifiques d’espèces animales ou végétales \n"; + print " appartenant à une liste finie. En plus des noms in-extenso, ce programme recherche \n"; + print " aussi les formes abrégées, par exemple : “C. lupus” pour “Canis lupus”. \n"; + print " N.B. : la liste et les textes doivent être en UTF-8. \n\n"; + print $usage; + print "Options :\n"; + print " -c tient compte de la casse (majuscule/minuscule) des termes recherchés \n"; + print " -e indique l'extension (e.g. “.txt”) du ou des fichiers textes à traiter \n"; + print " (possibilité d’avoir plusieurs extensions en répétant l'option) \n"; + print " -f indique le nom du fichier texte à traiter \n"; + print " -h affiche cette aide \n"; + print " -l indique le nom du fichier récapitulatif où sera écrit pour chaque fichier \n"; + print " traité le nombre de termes et d’occurrences trouvés\n"; + print " -q supprime l’affichage de la progression du travail \n"; + print " -r indique le répertoire contenant les fichiers textes à traiter \n"; + print " -s indique le nom du fichier où sera écrit le résultat du traitement \n"; + print " -t indique le nom du fichier contenant la ressource, c'est-à-dire la liste \n"; + print " des termes à rechercher \n\n"; + print "Ressource : \n"; + print " Le fichier de ressource contient un terme par ligne. On peut indiquer pour \n"; + print " un terme sa forme préférentielle en ajoutant après le terme une ou plusieurs \n"; + print " tabulations et le préférentiel. \n"; + print " Les lignes vides et celles commençant par le caractère “#” ne sont pas prises \n"; + print " en compte. De plus, la ressource peut être un fichier compressé par “gzip” ou \n"; + print " “bzip2”. \n\n"; + print "Résultat : \n"; + print " Le fichier résultat contient une ligne par occurrence trouvée. Chaque ligne \n"; + print " est formée de 4 champs séparés par une tabulation. On a respectivement le nom \n"; + print " du fichier traité (“STDIN” dans le cas de l'entrée standard), le terme tel \n"; + print " qu'il est dans la ressource, le terme tel qu'il apparait dans le texte analysé \n"; + print " et, dans le cas d'un synonyme, la forme préférentielle du terme. \n\n"; + exit 0; + } + +# Vérification de la présence des options obligatoires +usage(2) if not $table; + +if ( $log ) { + open(LOG, ">:utf8", "$log") or die "$!,"; + } +else { + open(LOG, "> /dev/null") or die "$!,"; + } + +if ( ! -f $table ) { + print STDERR "$programme : fichier \"$table\" absent\n"; + usage(5); + } +elsif ( $table =~ /\.g?[zZ]\Z/ ) { + open(TAB, "gzip -cd $table |") or die "$!, "; + binmode TAB, ":utf8"; + } +elsif ( $table =~ /\.bz2\Z/ ) { + open(TAB, "bzip2 -cd $table |") or die "$!, "; + binmode TAB, ":utf8"; + } +else { + open(TAB, "<:utf8", $table) or die "$!, "; + } + +$SIG{'HUP'} = 'nettoye'; +$SIG{'INT'} = 'nettoye'; +$SIG{'TERM'} = 'nettoye'; + +print STDERR "\r", " " x 75, "\r Chargement de la ressource ... " if not $quiet; + +while () { + next if /^#/o or /^\s*$/o; + chomp; + s/\r//go; + + # Vérification de jeu de caractères (doit être UTF-8) + if ( not is_utf8($_, Encode::FB_QUIET) ) { + print STDERR "Erreur : la table de référence doit être en UTF-8\n"; + exit 6; + } + + my $pref = ""; + my $terme = ""; + if ( /\t+/o ) { + ($terme, $pref) = split(/\t+/o); + } + else { + $terme = $_; + } + $terme =~ s/^\p{IsSpace}+//o; + $terme =~ s/\p{IsSpace}+\z//o; +# $terme =~ s/\p{IsSpace}\p{IsSpace}+/ /o; + my $str = $terme; + if ( $terme =~ m|^\p{IsSpace}*\Z| or $terme =~ m|^\p{IsWord}-?\Z| ) { + print STDERR "Terme refusé : \"$terme\"\n"; + next; + } + $terme = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $terme))); + $terme =~ s/ +/ /g; + if ( not $casse ) { + $terme = lc($terme); + } + if ( not $str{$terme} ) { + $str{$terme} = $str; + my ($genre) = $str =~ /^(.+?) /o; + $genre{$genre} ++; + if ( $casse ) { + $str{$genre} = $genre if not $str{$genre}; + } + else { + my $tmp = lc($genre); + $str{$tmp} = $genre; + $genre = $tmp; + } + push(@{$liste{$genre}}, $terme); + } + else { +# print STDERR "Erreur : doublon \"$str{$terme}\" et \"$str\"\n"; + print LOG "doublon \"$str{$terme}\" et \"$str\"\n"; + next; + } + if ( $pref ) { + $pref =~ s/^\p{IsSpace}+//o; + $pref =~ s/\p{IsSpace}+\z//o; +# $pref =~ s/\p{IsSpace}\p{IsSpace}+/ /o; + $str = $pref; + if ( $pref =~ m|^\p{IsSpace}*\Z| or $terme =~ m|^\p{IsWord}-?\Z| ) { + print STDERR "Préférentiel refusé : \"$pref\"\n"; + next; + } + $pref = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $terme))); + $pref =~ s/ +/ /g; + if ( not $casse ) { + $pref = lc($pref); + } + if ( not $str{$pref} ) { + $str{$pref} = $str; + my ($genre) = $str =~ /^(.+?) /o; + $genre = lc($genre) if not $casse; + push(@{$liste{$genre}}, $pref); + } + $pref{$terme} = $str; + } + } +close TAB; + +my $prefRef = \%pref; +my $strRef = \%str; +my $fleche = ""; +my @resultats = (); + +foreach my $genre (sort keys %liste) { + if ( $casse ) { + push(@table, sort @{$liste{$genre}}, $genre); + } + else { + push(@table, sort @{$liste{$genre}}, lc($genre)); + } + } +my $nb = $#table + 1; + +if ( $nb == 0 ) { + print STDERR "\r", " " x 75, "\r Aucun terme présent dans la liste\n"; + exit 3; + } + +if ( not $quiet ) { + my $tmp = $nb; + 1 while $tmp =~ s/(\d)(\d\d\d)\b/$1.$2/o; + print STDERR "\r", " " x 75, "\r $tmp termes présents dans la liste\n" ; + } + +select(STDERR); +$| = 1; +select (STDOUT); + +if ( $sortie ) { + open(OUT, ">:utf8", $sortie) or die "$!,"; + select OUT; + } + +if ( $fichier ) { + traite($fichier); + } +elsif ( $repertoire ) { + opendir(DIR, $repertoire) or die "$!,"; + my @fichiers = (); + if ( @extensions ) { + my $extensions = "(" . join("|", map {s/^\.//o; $_;} @extensions) . ")"; + @fichiers = grep(/\.$extensions\z/, grep(!/^\./o, readdir(DIR))); + } + else { + @fichiers = grep(!/^\./o, readdir(DIR)); + } + closedir(DIR); + foreach $fichier (sort @fichiers) { + traite("$repertoire/$fichier"); + } + } +else { + traite('-'); + } + +nettoye(); + + +exit 0; + + +sub usage +{ +my $retour = shift; + +print STDERR $usage; + +exit $retour; +} + +sub dich +{ +my ($key, $tref, $nbi) = @_; +my ($binf) = -1; +my ($bsup) = $nbi; + +while ( $bsup > $binf + 1 ) { + my $bmid = int ( ( $bsup + $binf) / 2 ); + my $comp = $key cmp $tref->[$bmid]; + return $bmid if $comp == 0; + if ( $comp > 0 ) { + $binf = $bmid; + } + else { + $bsup = $bmid; + } + } +return (- $bsup - 1); +} + +sub traite +{ +my $input = shift; + +my $nom = ""; +if ( $input eq '-' ) { + open(INP, "<&STDIN") or die "Impossible de dupliquer STDIN: $!,"; + binmode(INP, ":utf8"); + $nom = "STDIN"; + } +else { + open(INP, "<:utf8", $input) or die "$!,"; + ($nom) = $input =~ m|^(?:.*/)?(.+)|o; + } + +my $texte = ""; +my @para = (); +my %tmp = (); + +# On pense à vides la liste +@resultats = (); + +# Première passe -> fléche simple +$fleche = '->'; + +print STDERR "\r", " " x 75, "\r Traite le fichier $nom " if not $quiet; + +while() { + # Vérification de jeu de caractères (doit être UTF-8) + if ( not is_utf8($_, Encode::FB_QUIET) ) { + if ( $nom eq 'STDIN' ) { + print STDERR "Erreur : le texte en entrée standard doit être en UTF-8\n"; + } + else { + print STDERR "Erreur : le fichier \"$nom\" doit être en UTF-8\n"; + } + exit 7; + } + + if ( /^\s*$/o ) { + if ( $texte ) { + push(@para, $texte); + push(@resultats, recherche($nom, $texte)); + $texte = ""; + } + next; + } + tr/\n\r/ /s; + $texte .= $_; + } + +if ( $texte ) { + push(@resultats, recherche($nom, $texte)); + $texte = ""; + } + +close INP; + +# Penser au cas où on ne trouve rien lors de la première passe +if ( not @resultats ) { + print LOG "0\t0\t$nom\n"; + return; + } + +# Deuxième passe => fléche double +$fleche = '=>'; + +# Préparation de la table +my @tmp1 = sort grep {not $tmp{$_} ++;} @resultats; +my @tmp2 = (); +%tmp = (); +foreach my $terme (@tmp1) { + my ($mot) = split(/\p{IsSpace}+/o, $terme); + $mot = lc($mot) if not $casse; + push(@tmp2, $mot); + if ( $liste{$mot} ) { + push(@tmp2, @{$liste{$mot}}); + } + else { + push(@tmp2, grep(/^$mot\p{IsSpace}/, @table)); + } + } +@tmp1 = sort grep {not $tmp{$_} ++;} @tmp2; + +my %tmpPref = (); +my %tmpStr = (); + +@tmp2 = (); +foreach my $terme (@tmp1) { + if ( $casse ) { + my $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $terme))); + push(@tmp2, $terme); + $tmpStr{$str} = $terme; + if ( $terme =~ /^(\p{IsUpper})\P{IsSpace}+\p{IsSpace}+(.+)/o ) { + my $abrev = "$1. $2"; + $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $abrev))); + push(@tmp2, $str); + $tmpStr{$str} = $abrev; + if ( $tmpPref{$str} ) { + $tmpPref{$str} .= " ; $terme"; + } + else { + $tmpPref{$str} = $terme; + } + } + } + else { + my $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, lc($terme)))); + push(@tmp2, $str); + if ( $str{$terme} ) { + $tmpStr{$terme} = $str{$terme}; + $tmpStr{$str} = $str{$terme} if $str ne $terme; + } + if ( $terme =~ /^(\p{IsLower})\P{IsSpace}+\p{IsSpace}+(.+)/o ) { + my $abrev = "$1. $2"; + $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, lc($abrev)))); + push(@tmp2, $str); + $tmpStr{$str} = "\u$abrev"; + if ( $tmpPref{$str} ) { + $tmpPref{$str} .= " ; " . $terme; + } + else { + $tmpPref{$str} = $terme; + } + } + } + } +%tmp = (); +@tmp1 = sort grep{not $tmp{$_} ++;} @tmp2; + +@resultats = (); +%tmp = (); + +# On point sur les nouveaux hachages ... +$prefRef = \%tmpPref; +$strRef = \%tmpStr; + +foreach my $para (@para) { + push(@resultats, recherche($nom, $para, \@tmp1)); + } + +# Traitement des ambigüités toujours présentes +@tmp1 = grep{not $tmp{$_} ++;} grep(/\t\?.+\?\z/, @resultats); +if ( @tmp1 ) { + @tmp2 = grep(!/\t\?.+\?\z/, @resultats); + foreach my $item (@tmp1) { + my ($t1, $t2, $t3) = split(/\t/, $item); + %tmp = (); + my @tmp3 = grep{not $tmp{$_} ++;} grep(/./, split(/\?/, $t3)); + my %score = (); + foreach my $pref (@tmp3) { + $score{$pref} = grep(/$t1\t[^\t]+\t$pref\z/, @tmp2); + } + my @tmp = sort {$score{$b} <=> $score{$a}} grep {$score{$_} > 0;} keys %score; + if ( $#tmp == 0 ) { + foreach my $resultat (@resultats) { + if ( $resultat eq $item ) { + $resultat = "$t1\t$t2\t$tmp[0]"; + } + } + } + next if @tmp; + %score = (); + foreach my $pref (@tmp3) { + $score{$pref} = grep(/\t$pref\z/, @tmp2); + } + @tmp = sort {$score{$b} <=> $score{$a}} grep {$score{$_} > 0;} keys %score; + if ( $#tmp == 0 ) { + foreach my $resultat (@resultats) { + if ( $resultat eq $item ) { + $resultat = "$t1\t$t2\t$tmp[0]"; + } + } + next; + } + %tmp = (); + foreach my $pref (@tmp3) { + my ($genre) = $pref =~ /^(.+?) /o; + $tmp{$genre} ++; + } + for ( my $n = 1 ; $n <= $#resultats ; $n ++ ) { + if ( $resultats[$n] eq $item ) { + for ( my $m = $n ; $m >= 0 ; $m -- ) { + my ($terme) = $resultats[$m] =~ /^(.+?)\s/o; + next if not $genre{$terme}; + if ( $tmp{$terme} ) { + @tmp = grep(/^$terme /, @tmp3); + if ( $#tmp == 0 ) { + foreach my $resultat (@resultats) { + if ( $resultat eq $item ) { + $resultat = "$t1\t$t2\t$tmp[0]"; + } + } + } + } + } + } + } + } + } + + +# ... et retour aux hachages par défaut. +$prefRef = \%pref; +$strRef = \%str; + +while( my $resultat = shift @resultats ) { + my @champs = split(/\t/, $resultat); + next if $genre{$champs[0]}; + print STDERR "\r", " " x 75, "\r"; + print "$nom\t$resultat\n"; + if ( $champs[2] ) { + if ( $champs[2] =~ /^\?.+\?\z/o ) { + print STDERR "ATTENTION ! $nom : ambiguïté sur la forme non abrégée de “$champs[0]” !\n"; + print LOG "ATTENTION ! $nom : ambiguïté sur la forme non abrégée de “$champs[0]” !\n"; + } + else { + $tmp{$champs[2]} ++; + } + } + else { + $tmp{$champs[0]} ++; + } + } + +my $nb_refs = 0; +my $nb_occs = 0; + +foreach my $ref (keys %tmp) { + $nb_refs ++; + $nb_occs += $tmp{$ref}; + } + +printf LOG "%d\t%d\t%s\n", $nb_refs, $nb_occs, $nom; +} + +sub recherche +{ +my $cle = undef; +my $orig = undef; +my $tref = undef; +my $nbi = $nb; + +($cle, $orig, $tref) = @_; + +if ( not defined $tref ) { + $tref = \@table; + } +else { + $nbi = $#{$tref} + 1; + } + +$orig =~ s/^\p{IsSpace}+//o; +$orig =~ s/\p{IsSpace}+\z//o; + +my $rec = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $orig))); + +if ( ! $casse ) { + $rec = lc($rec); + } + +my $terme = ""; +my @matchs = (); + +while ( length($rec) ) { + my $retour = dich($rec, $tref, $nbi); + if ( $retour > -1 ) { + print STDERR "\r", " " x 75, "\r" if not $quiet; + $terme = $tref->[$retour]; + my $tmp = $tref->[$retour]; + $terme =~ s/(\P{IsWord})/\\$1/g; + $terme =~ s/\\ / */og; + $terme =~ s/([^\x20-\x7F])/./og; + if ( $orig =~ /^$terme\b/ or ( ! $casse and $orig =~ /^$terme\b/i ) ) { + my $chaine = $&; + if ( $chaine =~ /\p{IsUpper}/o ) { + push(@matchs, "$strRef->{$tmp}\t$chaine"); + if ( defined $prefRef->{$tmp} ) { + if ( $prefRef->{$tmp} =~ / ; /o ) { + my @possibles = split(/ ; /, $prefRef->{$tmp}); + my $probable = desambiguise(\@possibles, \@matchs); + if ( $probable ) { + $matchs[$#matchs] .= "\t$strRef->{$probable}"; + } + else { + $probable = join('?', map {$strRef->{$_}} @possibles); + $matchs[$#matchs] .= "\t?$probable?"; + } + } + else { + $matchs[$#matchs] .= "\t$strRef->{$prefRef->{$tmp}}"; + } + } + } + } + else { + push(@matchs, "$strRef->{$tmp}\t*** ERREUR ***"); + print STDERR "ERREUR (1) sur la recherche de l'original $cle\n"; + } + if ( not $quiet and not $genre{$strRef->{$tmp}} ) { +# if ( not $quiet ) { + print STDERR "$cle $fleche $strRef->{$tmp}\n"; + print STDERR " Traite le fichier $cle "; + } + } + else { + $retour = - 2 - $retour; + $terme = $tref->[$retour]; + my ($debut) = $terme =~ m|^(.*?\p{IsWord}+)|; + $debut =~ s/(\P{IsWord})/\\$1/g; + do { + $terme =~ s/(\P{IsWord})/\\$1/g; + if ( $rec =~ /^$terme\b/ ) { # Mot exact seulement + print STDERR "\r", " " x 75, "\r" if not $quiet; + $terme =~ s/\\ /\\p{IsSpace}*/og; + $terme =~ s/([^\x20-\x7F])/./og; + my $tmp = $tref->[$retour]; + if ( $orig =~ /^$terme/ or ( ! $casse and $orig =~ /^$terme/i ) ) { + my $chaine = $&; + if ( $chaine =~ /\p{IsUpper}/o ) { + push(@matchs, "$strRef->{$tmp}\t$chaine"); + if ( defined $prefRef->{$tmp} ) { + if ( $prefRef->{$tmp} =~ / ; /o ) { + my @possibles = split(/ ; /, $prefRef->{$tmp}); + my $probable = desambiguise(\@possibles, \@matchs); + if ( $probable ) { + $matchs[$#matchs] .= "\t$strRef->{$probable}"; + } + else { + $probable = join('?', map {$strRef->{$_}} @possibles); + $matchs[$#matchs] .= "\t?$probable?"; + } + } + else { + $matchs[$#matchs] .= "\t$strRef->{$prefRef->{$tmp}}"; + } + } + } + } + else { + push(@matchs, "$strRef->{$tmp}\t*** ERREUR ***"); + print STDERR "ERREUR (2) sur la recherche de l'original $cle\n"; + } + if ( not $quiet and not $genre{$strRef->{$tmp}} ) { +# if ( not $quiet ) { + print STDERR "$cle $fleche $strRef->{$tmp}\n"; + print STDERR " Traite le fichier $cle "; + } + $retour = 0; + } + if ( $retour > 0 ) { + $terme = $tref->[--$retour]; + } + else { + $terme = ""; + } + } until $terme !~ /^$debut/; + } + $rec =~ s/^\P{IsSpace}+\p{IsSpace}?//; + if ( $orig =~ /^\p{IsWord}+\p{IsSpace}*/ ) { + $orig =~ s/^\p{IsWord}+\p{IsSpace}*//; + } + elsif ( $orig =~ /^\p{IsSpace}+\P{IsWord}\p{IsSpace}*/ ) { + $orig =~ s/^\p{IsSpace}+\P{IsWord}\p{IsSpace}*//; + } + elsif ( $orig =~ /^\P{IsWord}\p{IsSpace}*/ ) { + $orig =~ s/^\P{IsWord}\p{IsSpace}*//; + } + else { + print STDERR "ERREUR sur le texte intégral : $orig\n"; + } + } + +return @matchs; +} + +sub desambiguise +{ +my $ptrPossibles = shift; +my $ptrMatchs = shift; +return undef; +my @references = (); + +foreach my $resultat (@resultats) { + my @tmp = split(/\t/, $resultat); + if ( $tmp[2] ) { + next if $tmp[2] =~ /^\?.+\?\z/o; + push(@references, $tmp[2]); + } + elsif ( $tmp[0] !~ /^\w\. /o ) { + push(@references, $tmp[0]); + } + } + +foreach my $resultat (@{$ptrMatchs}) { + my @tmp = split(/\t/, $resultat); + if ( $tmp[2] ) { + next if $tmp[2] =~ /^\?.+\?\z/o; + push(@references, $tmp[2]); + } + elsif ( $tmp[0] !~ /^\w\. /o ) { + push(@references, $tmp[0]); + } + } + +my %score = (); +my %tmp = (); + +my @liste = grep {not $tmp{$_} ++;} reverse @references; + +foreach my $possible (@{$ptrPossibles}) { + foreach my $item (@liste) { + if ( $item eq $str{$possible} ) { + $score{$possible} = 1 ; + } + } + } + +my @tmp = sort keys %score; +if ( $#tmp == 0 ) { + return $tmp[0]; + } + +foreach my $item (@liste) { + my ($genre) = $item =~ /^(\S+) /o; + next if not $genre; + if ( not $casse ) { + $genre = lc($genre); + } + my ($possible) = grep(/^$genre /, @{$ptrPossibles}); + return $possible if $possible; + } +} + +sub nettoye +{ +if ( not $quiet ) { + print STDERR "\r", " " x 75, "\r"; + print STDERR "\n"; + } + +exit 0; +}