File Coverage

lib/Convert/Pheno/Mapping.pm
Criterion Covered Total %
statement 138 153 90.2
branch 34 48 70.8
condition 9 17 52.9
subroutine 29 31 93.5
pod 0 16 0.0
total 210 265 79.2


line stmt bran cond sub pod time code
1             package Convert::Pheno::Mapping;
2              
3 6     6   50 use strict;
  6         12  
  6         182  
4 6     6   37 use warnings;
  6         10  
  6         135  
5 6     6   25 use autodie;
  6         10  
  6         30  
6              
7             #use Carp qw(confess);
8 6     6   32001 use feature qw(say);
  6         20  
  6         401  
9 6     6   37 use utf8;
  6         10  
  6         41  
10 6     6   170 use Data::Dumper;
  6         11  
  6         364  
11 6     6   3751 use JSON::XS;
  6         25856  
  6         381  
12 6     6   3368 use Time::HiRes qw(gettimeofday);
  6         9472  
  6         22  
13 6     6   4436 use POSIX qw(strftime);
  6         32223  
  6         41  
14 6     6   9128 use Scalar::Util qw(looks_like_number);
  6         10  
  6         343  
15 6     6   39 use List::Util qw(first);
  6         12  
  6         363  
16 6     6   2815 use Convert::Pheno::SQLite;
  6         18  
  6         927  
17             binmode STDOUT, ':encoding(utf-8)';
18 6     6   49 use Exporter 'import';
  6         21  
  6         362  
19             our @EXPORT =
20             qw(map_ethnicity map_ontology dotify_and_coerce_number iso8601_time _map2iso8601 map_reference_range map_age_range map2redcap_dict map2ohdsi convert2boolean find_age randStr map_operator_concept_id map_info_field map_omop_visit_occurrence dot_date2iso remap_mapping_hash);
21              
22 6     6   39 use constant DEVEL_MODE => 0;
  6         16  
  6         16255  
23              
24             # Global hash
25             my %seen = ();
26              
27             #############################
28             #############################
29             # SUBROUTINES FOR MAPPING #
30             #############################
31             #############################
32              
33             sub map_ethnicity {
34              
35 40     40 0 69 my $str = shift;
36 40         81 my %ethnicity = ( map { $_ => 'NCIT:C41261' } ( 'caucasian', 'white' ) );
  80         241  
37              
38             # 1, Caucasian | 2, Hispanic | 3, Asian | 4, African/African-American | 5, Indigenous American | 6, Mixed | 9, Other";
39 40         230 return { id => $ethnicity{ lc($str) }, label => $str };
40             }
41              
42             sub map_ontology {
43              
44             # Most of the execution time goes to this subroutine
45             # We will adopt two estragies to gain speed:
46             # 1 - Prepare once, excute often (almost no gain in speed :/ )
47             # 2 - Create a global hash with "seen" queries (+++huge gain)
48              
49             #return { id => 'dummy', label => 'dummy' } # test speed
50              
51             # Checking for existance in %seen
52 81000     81000 0 128023 my $tmp_query = $_[0]->{query};
53             say "Skipping searching for <$tmp_query> as it already exists"
54 81000         86762 if DEVEL_MODE && exists $seen{$tmp_query};
55              
56             # return if terms has already been searched and exists
57             # Not a big fan of global stuff...
58             # ¯\_(ツ)_/¯
59             # Premature return
60 81000 100       222498 return $seen{$tmp_query} if exists $seen{$tmp_query}; # global
61              
62 206         230 say "searching for <$tmp_query>" if DEVEL_MODE;
63              
64             # return something if we know 'a priori' that the query won't exist
65             #return { id => 'NCIT:NA000', label => $tmp_query } if $tmp_query =~ m/xx/;
66              
67             # Ok, now it's time to start the subroutine
68 206         378 my $arg = shift;
69 206         344 my $column = $arg->{column};
70 206         328 my $ontology = $arg->{ontology};
71 206         312 my $self = $arg->{self};
72 206         410 my $search = $self->{search};
73 206         416 my $print_hidden_labels = $self->{print_hidden_labels};
74 206         398 my $text_similarity_method = $self->{text_similarity_method};
75 206         326 my $min_text_similarity_score = $self->{min_text_similarity_score};
76              
77             # Die if user wants OHDSI w/o flag -ohdsi-db
78             die
79             "Could not find the concept_id:<$tmp_query> in the provided <CONCEPT> table.\nPlease use the flag <--ohdsi-db> to enable searching at Athena-OHDSI database\n"
80 206 50 33     568 if ( $ontology eq 'ohdsi' && !$self->{ohdsi_db} );
81              
82             # Perform query
83             my ( $id, $label ) = get_ontology(
84             {
85 206         1680 sth_column_ref => $self->{sth}{$ontology}{$column},
86             query => $tmp_query,
87             ontology => $ontology,
88             column => $column,
89             search => $search,
90             text_similarity_method => $text_similarity_method,
91             min_text_similarity_score => $min_text_similarity_score
92             }
93             );
94              
95             # Add result to global %seen
96 206         1657 $seen{$tmp_query} = { id => $id, label => $label }; # global
97              
98             # id and label come from <db> _label is the original string (can change on partial matches)
99 206 50       1409 return $print_hidden_labels
100             ? { id => $id, label => $label, _label => $tmp_query }
101             : { id => $id, label => $label };
102             }
103              
104             sub dotify_and_coerce_number {
105              
106 1828645     1828645 0 1986931 my $val = shift;
107 1828645         2174378 ( my $tr_val = $val ) =~ tr/,/./;
108              
109             # looks_like_number does not work with commas so we must tr first
110             #say "$val === ", looks_like_number($val);
111             # coercing to number $tr_val and avoiding value = ""
112             return
113 1828645 100       4354280 looks_like_number($tr_val) ? 0 + $tr_val
    100          
114             : $val eq '' ? undef
115             : $val;
116             }
117              
118             sub iso8601_time {
119              
120             # Standard modules (gmtime()===>Coordinated Universal Time(UTC))
121             # NB: The T separates the date portion from the time-of-day portion.
122             # The Z on the end means UTC (that is, an offset-from-UTC of zero hours-minutes-seconds).
123             # - The Z is pronounced “Zulu”.
124 1     1 0 10 my $now = time();
125 1         244 return strftime( '%Y-%m-%dT%H:%M:%SZ', gmtime($now) );
126             }
127              
128             sub _map2iso8601 {
129              
130 69770     69770   395336 my ( $date, $time ) = split /\s+/, shift;
131              
132             # UTC
133 69770 50 66     412343 return $date
134             . ( ( defined $time && $time =~ m/^T(.+)Z$/ ) ? $time : 'T00:00:00Z' );
135             }
136              
137             sub map_reference_range {
138              
139 2785     2785 0 3612 my $arg = shift;
140 2785         3700 my $field = $arg->{field};
141 2785         2982 my $redcap_dict = $arg->{redcap_dict};
142 2785         3101 my $unit = $arg->{unit};
143 2785         5457 my %hash = ( low => 'Text Validation Min', high => 'Text Validation Max' );
144             my $hashref = {
145             unit => $unit,
146 2785         4007 map { $_ => undef } qw(low high)
  5570         13102  
147             }; # Initialize low,high to undef
148 2785         4788 for my $range (qw (low high)) {
149             $hashref->{$range} =
150 5570         10200 dotify_and_coerce_number( $redcap_dict->{$field}{ $hash{$range} } );
151             }
152              
153 2785         12345 return $hashref;
154             }
155              
156             sub map_age_range {
157              
158 80     80 0 167 my $str = shift;
159              
160             # Premature return if not range
161 80 50       622 return { age =>
162             { iso8601duration => 'P' . dotify_and_coerce_number($str) . 'Y' } }
163             unless $str =~ m/\-|\+/;
164              
165             # if range
166 80         208 $str =~ s/\+/\-999/; # from '70+' '70-999'
167 80         307 my ( $start, $end ) = split /\-/, $str;
168              
169             return {
170 80         228 ageRange => {
171             start => {
172             iso8601duration => 'P' . dotify_and_coerce_number($start) . 'Y'
173             },
174             end =>
175             { iso8601duration => 'P' . dotify_and_coerce_number($end) . 'Y' }
176             }
177             };
178             }
179              
180             sub map2redcap_dict {
181              
182 20670     20670 0 24295 my $arg = shift;
183             my ( $redcap_dict, $participant, $field, $labels ) = (
184             $arg->{redcap_dict}, $arg->{participant},
185             $arg->{field}, $arg->{labels}
186 20670         32901 );
187              
188             # Options:
189             # labels = 1
190             # _labels
191             # labels = 0
192             # 'Field Note'
193             return $labels
194             ? $redcap_dict->{$field}{_labels}{ $participant->{$field} }
195 20670 100       74137 : $redcap_dict->{$field}{'Field Note'};
196             }
197              
198             sub map2ohdsi {
199              
200 139999     139999 0 181479 my $arg = shift;
201             my ( $ohdsi_dic, $concept_id, $self ) =
202 139999         229752 ( $arg->{ohdsi_dic}, $arg->{concept_id}, $arg->{self} );
203              
204             #######################
205             # OPTION A: <CONCEPT> #
206             #######################
207              
208             # NB1: Here we don't win any speed over using %seen as ...
209             # .. we are already searching in a hash
210             # NB2: $concept_id is stringified by hash
211 139999         244772 my ( $data, $id, $label, $vocabulary ) = ( (undef) x 4 );
212 139999 50       290136 if ( exists $ohdsi_dic->{$concept_id} ) {
213 139999         239639 $id = $ohdsi_dic->{$concept_id}{concept_code};
214 139999         191160 $label = $ohdsi_dic->{$concept_id}{concept_name};
215 139999         190973 $vocabulary = $ohdsi_dic->{$concept_id}{vocabulary_id};
216 139999         351442 $data = { id => qq($vocabulary:$id), label => $label };
217             }
218              
219             ######################
220             # OPTION B: External #
221             ######################
222              
223             else {
224 0         0 $data = map_ontology(
225             {
226             query => $concept_id,
227             column => 'concept_id',
228             ontology => 'ohdsi',
229             self => $self
230             }
231             );
232             }
233 139999         288263 return $data;
234             }
235              
236             sub convert2boolean {
237              
238 40     40 0 113 my $val = lc(shift);
239             return
240 40 50 66     374 ( $val eq 'true' || $val eq 'yes' ) ? JSON::XS::true
    100 33        
241             : ( $val eq 'false' || $val eq 'no' ) ? JSON::XS::false
242             : undef; # unknown = undef
243              
244             }
245              
246             sub find_age {
247              
248             # Not using any CPAN module for now
249             # Adapted from https://www.perlmonks.org/?node_id=9995
250              
251             # Assuming $birth_month is 0..11
252 70059     70059 0 88164 my $arg = shift;
253 70059         83245 my $birth = $arg->{birth_day};
254 70059         79838 my $date = $arg->{date};
255              
256             # Not a big fan of premature return, but it works here...
257             # ¯\_(ツ)_/¯
258 70059 50 33     213029 return unless ( $birth && $date );
259              
260 70059         556335 my ( $birth_year, $birth_month, $birth_day ) =
261             ( split /\-|\s+/, $birth )[ 0 .. 2 ];
262 70059         207900 my ( $year, $month, $day ) = ( split /\-/, $date )[ 0 .. 2 ];
263              
264             #my ($day, $month, $year) = (localtime)[3..5];
265             #$year += 1900;
266              
267 70059         157146 my $age = $year - $birth_year;
268 70059 100       317738 $age--
269             unless sprintf( "%02d%02d", $month, $day ) >=
270             sprintf( "%02d%02d", $birth_month, $birth_day );
271 70059         324109 return $age . 'Y';
272             }
273              
274             sub randStr {
275              
276             #https://www.perlmonks.org/?node_id=233023
277             return join( '',
278 1     1 0 5 map { ( 'a' .. 'z', 'A' .. 'Z', 0 .. 9 )[ rand 62 ] } 0 .. shift );
  9         28  
279             }
280              
281             sub map_operator_concept_id {
282              
283 0     0 0 0 my $arg = shift;
284 0         0 my $id = $arg->{operator_concept_id};
285 0         0 my $val = $arg->{value_as_number};
286 0         0 my $unit = $arg->{unit};
287              
288             # Define hash for possible values
289 0         0 my %operator_concept_id = ( 4172704 => 'GT', 4172756 => 'LT' );
290              
291             # 4172703 => 'EQ';
292              
293             # $hasref will be used for return
294 0         0 my $hashref = undef;
295              
296             # Only for GT || LT
297 0 0       0 if ( exists $operator_concept_id{$id} ) {
298             $hashref = {
299             unit => $unit,
300 0         0 map { $_ => undef } qw(low high)
  0         0  
301             }; # Initialize low,high to undef
302 0 0       0 if ( $operator_concept_id{$id} eq 'GT' ) {
303 0         0 $hashref->{high} = dotify_and_coerce_number($val);
304             }
305             else {
306 0         0 $hashref->{low} = dotify_and_coerce_number($val);
307             }
308             }
309 0         0 return $hashref;
310             }
311              
312             sub map_omop_visit_occurrence {
313              
314             # key eq 'visit_occurrence_id'
315             # { '85' =>
316             # {
317             # 'admitting_source_concept_id' => 0,
318             # 'admitting_source_value' => undef,
319             # 'care_site_id' => '\\N',
320             # 'discharge_to_concept_id' => 0,
321             # 'discharge_to_source_value' => undef,
322             # 'person_id' => 1,
323             # 'preceding_visit_occurrence_id' => 82,
324             # 'provider_id' => '\\N',
325             # 'visit_concept_id' => 9201,
326             # 'visit_end_date' => '1981-08-19',
327             # 'visit_end_datetime' => '1981-08-19 00:00:00',
328             # 'visit_occurrence_id' => 85,
329             # 'visit_source_concept_id' => 0,
330             # 'visit_source_value' => '7879d5b2-1af2-49a7-a801-121de124c6af',
331             # 'visit_start_date' => '1981-08-18',
332             # 'visit_start_datetime' => '1981-08-18 00:00:00',
333             # 'visit_type_concept_id' => 44818517
334             # }
335             # }
336              
337 69193     69193 0 98965 my $arg = shift;
338 69193         88908 my $self = $arg->{self};
339 69193         76523 my $ohdsi_dic = $arg->{ohdsi_dic};
340 69193         82384 my $person_id = $arg->{person_id};
341 69193         78039 my $visit_occurrence_id = $arg->{visit_occurrence_id};
342 69193         86489 my $visit_occurrence = $self->{visit_occurrence};
343              
344             # Premature return
345 69193 100       120451 return undef if $visit_occurrence_id eq '\\N'; # perlcritic Severity: 5
346              
347             # *** IMPORTANT ***
348             # EUNOMIA instance has mismatches between the person_id -- visit_occurrence_id
349             # For instance, person_id = 1 has only visit_occurrence_id = 85, but on tables it has:
350             # 82, 84, 42, 54, 41, 25, 76 and 81
351              
352             # warn if we don't have $visit_occurrence_id in VISIT_OCURRENCE
353 68663 100       177945 unless ( exists $visit_occurrence->{$visit_occurrence_id} ) {
354 68414         65592 warn
355             "Sorry, but <visit_occurrence_id:$visit_occurrence_id> does not exist for <person_id:$person_id>\n"
356             if DEVEL_MODE;
357              
358             # Premature return
359 68414         148561 return undef; # perlcritic Severity: 5
360             }
361              
362             # Getting pointer to the hash element
363 249         913 my $hashref = $visit_occurrence->{$visit_occurrence_id};
364              
365             my $concept = map2ohdsi(
366             {
367             ohdsi_dic => $ohdsi_dic,
368             concept_id => $hashref->{visit_concept_id},
369 249         1469 self => $self
370              
371             }
372             );
373              
374             # *** IMPORTANT ***
375             # Ad hoc to avoid using --ohdsi-db while we find a solution to EUNOMIA not being self-contained
376 249         933 my $ad_hoc_44818517 = {
377             id => "Visit Type:OMOP4822465",
378             label => "Visit derived from encounter on claim"
379             };
380             my $type =
381             $hashref->{visit_type_concept_id} == 44818517
382             ? $ad_hoc_44818517
383             : map2ohdsi(
384             {
385             ohdsi_dic => $ohdsi_dic,
386             concept_id => $hashref->{visit_type_concept_id},
387 249 50       1030 self => $self
388              
389             }
390             );
391 249         671 my $start_date = _map2iso8601( $hashref->{visit_start_date} );
392 249         720 my $end_date = _map2iso8601( $hashref->{visit_end_date} );
393 249         984 my $info = { VISIT_OCCURENCE => { OMOP_columns => $hashref } };
394              
395             return {
396             _info => $info,
397             id => $visit_occurrence_id,
398             concept => $concept,
399             type => $type,
400             start_date => $start_date,
401             end_date => $end_date,
402             occurrence_id => $hashref->{visit_occurrence_id}
403 249         2084 };
404             }
405              
406             sub dot_date2iso {
407              
408             # We can get
409             # '', '1990.12.25', '1990-12-25'
410 330   100 330 0 755 my $date = shift // '';
411              
412             # Premature returns
413 330 100       639 return '1900-01-01' if $date eq '';
414 255 100       966 return $date if $date =~ m/^(\d{4})\-(\d{2})\-(\d{2})$/;
415              
416             # Split '1990.12.25'
417 153         514 my ( $d, $m, $y ) = split /\./, $date;
418              
419             # YYYYMMDD
420 153         497 return qq/$y-$m-$d/;
421             }
422              
423             sub is_multidimensional {
424              
425 0 0   0 0 0 return ref shift ? 1 : 0;
426             }
427              
428             sub remap_mapping_hash {
429              
430 1260     1260 0 2114 my ( $mapping_file, $term ) = @_;
431             my %hash_out = map {
432 1260         1794 $_, exists $mapping_file->{$term}{$_}
433 5040 100       12928 ? $mapping_file->{$term}{$_}
434             : undef
435             } (qw/fields dict map radio/);
436             $hash_out{ontology} =
437             exists $mapping_file->{$term}{ontology}
438             ? $mapping_file->{$term}{ontology}
439 1260 100       3521 : $mapping_file->{project}{ontology};
440             $hash_out{routesOfAdministration} =
441             $mapping_file->{$term}{routesOfAdministration}
442 1260 100       2653 if $term eq 'treatments';
443 1260         3323 return \%hash_out;
444             }
445              
446             1;