-
Notifications
You must be signed in to change notification settings - Fork 42
/
survey_enhancements.pl
executable file
·229 lines (222 loc) · 7.74 KB
/
survey_enhancements.pl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
#!/usr/bin/env perl
# Scans all UD treebanks for enhancement types in enhanced UD graphs.
# Copyright © 2020 Dan Zeman <zeman@ufal.mff.cuni.cz>
# License: GNU GPL
use utf8;
use open ':utf8';
binmode(STDIN, ':utf8');
binmode(STDOUT, ':utf8');
binmode(STDERR, ':utf8');
use Getopt::Long;
# We need to tell Perl where to find my UD and graph modules.
BEGIN
{
use Cwd;
my $path = $0;
my $currentpath = getcwd();
$currentpath =~ s/\r?\n$//;
$libpath = $currentpath;
if($path =~ m:/:)
{
$path =~ s:/[^/]*$:/:;
chdir($path);
$libpath = getcwd();
chdir($currentpath);
}
$libpath =~ s/\r?\n$//;
#print STDERR ("libpath=$libpath\n");
}
use lib $libpath;
use udlib;
sub usage
{
print STDERR ("Usage: perl survey_enhancements.pl --datapath /net/projects/ud --tbklist udsubset.txt\n");
print STDERR (" --datapath ... path to the folder where all UD_* treebank repositories reside\n");
print STDERR (" --tbklist .... file with list of UD_* folders to consider (e.g. treebanks we are about to release)\n");
print STDERR (" if tbklist is not present, all treebanks in datapath will be scanned\n");
}
my $datapath = '.';
my $tbklist;
GetOptions
(
'datapath=s' => \$datapath, # UD_* folders will be sought in this folder
'tbklist=s' => \$tbklist # path to file with treebank list; if defined, only treebanks on the list will be surveyed
);
my %treebanks;
if(defined($tbklist))
{
open(TBKLIST, $tbklist) or die("Cannot read treebank list from '$tbklist': $!");
while(<TBKLIST>)
{
s/^\s+//;
s/\s+$//;
my @treebanks = split(/\s+/, $_);
foreach my $t (@treebanks)
{
$t =~ s:/$::;
$treebanks{$t}++;
}
}
close(TBKLIST);
}
opendir(DIR, $datapath) or die("Cannot read the contents of '$datapath': $!");
my @folders = sort(grep {-d "$datapath/$_" && m/^UD_[A-Z]/} (readdir(DIR)));
closedir(DIR);
my $n = scalar(@folders);
print STDERR ("Found $n UD folders in '$datapath'.\n");
if(defined($tbklist))
{
my $n = scalar(keys(%treebanks));
print STDERR ("We will only scan those listed in $tbklist (the list contains $n treebanks but we have not checked yet which of them exist in the folder).\n");
}
else
{
print STDERR ("Warning: We will scan them all, whether their data is valid or not!\n");
}
if($datapath eq '.')
{
print STDERR ("Use the --datapath option to scan a different folder with UD treebanks.\n");
}
sleep(5);
# We need a mapping from the English names of the languages (as they appear in folder names) to their ISO codes.
# There is now also the new list of languages in YAML in docs-automation; this one has also language families.
my $languages_from_yaml = udlib::get_language_hash("$libpath/../docs-automation/codes_and_flags.yaml");
my %langnames;
my %langcodes;
foreach my $language (keys(%{$languages_from_yaml}))
{
# We need a mapping from language names in folder names (contain underscores instead of spaces) to language codes.
# Language names in the YAML file may contain spaces (not underscores).
my $usname = $language;
$usname =~ s/ /_/g;
$langcodes{$usname} = $languages_from_yaml->{$language}{lcode};
$langnames{$languages_from_yaml->{$language}{lcode}} = $language;
}
# Look for features in the data.
my %hash;
my %hitlanguages;
foreach my $folder (@folders)
{
# If we received the list of treebanks to be released, skip all other treebanks.
if(defined($tbklist) && !exists($treebanks{$folder}))
{
next;
}
# The name of the folder: 'UD_' + language name + optional treebank identifier.
# Example: UD_Ancient_Greek-PROIEL
my $language = '';
my $treebank = '';
my $langcode;
my $key;
if($folder =~ m/^UD_([A-Za-z_]+)(?:-([A-Za-z]+))?$/)
{
print STDERR ("$folder\n");
$language = $1;
$treebank = $2 if(defined($2));
if(exists($langcodes{$language}))
{
$langcode = $langcodes{$language};
$key = $langcode;
$key .= '_'.lc($treebank) if($treebank ne '');
my $nhits = 0;
chdir("$datapath/$folder") or die("Cannot enter folder '$datapath/$folder': $!");
# Collect enhanced graph properties from all CoNLL-U files in the folder using a dedicated script.
my $command = "cat *.conllu | $libpath/enhanced_graph_properties.pl";
open(PROPERTIES, "$command |") or die("Cannot run and read output of '$command': $!");
while(<PROPERTIES>)
{
s/\r?\n$//;
# We are looking for the following six lines:
# * Gapping: 0
# * Coord shared parent: 1145
# * Coord shared depend: 407
# * Controlled subject: 698
# * Relative clause: 0
# * Deprel with case: 55
if(m/^\*\s*(.+):\s*(\d+)$/)
{
my $property = $1;
my $count = $2;
$hash{$folder}{$property} = $count;
if($property ne 'Edge basic only' && $count>0)
{
$hash{$folder}{hit}++;
$hitlanguages{$langcode}++;
}
}
}
close(PROPERTIES);
}
}
}
my $n_languages_something = scalar(keys(%hitlanguages));
my $n_treebanks_something = 0;
my $n_treebanks_everything = 0;
my @treebanks = sort(keys(%hash));
my $maxlength;
foreach my $treebank (@treebanks)
{
my $l = length($treebank);
if(!defined($maxlength) || $l > $maxlength)
{
$maxlength = $l;
}
}
foreach my $treebank (@treebanks)
{
if($hash{$treebank}{hit})
{
$n_treebanks_something++;
my $g = $hash{$treebank}{'Gapping'};
my $p = $hash{$treebank}{'Coord shared parent'};
my $s = $hash{$treebank}{'Coord shared depend'};
my $x = $hash{$treebank}{'Controlled subject'};
my $r = $hash{$treebank}{'Relative clause'};
my $c = $hash{$treebank}{'Deprel with case'};
my $all = '';
if($g>0 && $p>0 && $s>0 && $x>0 && $r>0 && $c>0)
{
$all = '*';
$n_treebanks_everything++;
}
print(pad($treebank.$all, $maxlength+1), "\t");
print(pad("EB=$hash{$treebank}{'Edge basic only'}", 10), "\t");
print(pad("EBE=$hash{$treebank}{'Edge basic & enhanced'}", 11), "\t");
print(pad("EBe=$hash{$treebank}{'Edge enhanced type'}", 11), "\t");
print(pad("EBi=$hash{$treebank}{'Edge incompatible type'}", 11), "\t");
print(pad("EE=$hash{$treebank}{'Edge enhanced only'}", 10), "\t");
print(pad("G=$g", 7), "\t");
print(pad("P=$p", 7), "\t");
print(pad("S=$s", 7), "\t");
print(pad("X=$x", 7), "\t");
print(pad("R=$r", 7), "\t");
print("C=$c\n");
}
}
print("\n");
print("Total $n_treebanks_everything treebanks have all types of enhancements.\n");
print("Total $n_treebanks_something treebanks have at least one type of enhancement.\n");
print("Total $n_languages_something languages have at least one type of enhancement in at least one treebank.\n");
#------------------------------------------------------------------------------
# Adds spaces before or after a string to achieve a specified length.
#------------------------------------------------------------------------------
sub pad
{
my $string = shift;
my $target = shift; # target length
my $before = shift;
my $l = length($string);
if($target > $l)
{
my $spaces = ' ' x ($target-$l);
if($before)
{
$string = $spaces.$string;
}
else
{
$string = $string.$spaces;
}
}
return $string;
}