File Coverage

lib/R/YapRI/Interpreter/Perl.pm
Criterion Covered Total %
statement 101 104 97.1
branch 47 52 90.3
condition 9 15 60.0
subroutine 10 10 100.0
pod 1 1 100.0
total 168 182 92.3


line stmt bran cond sub pod time code
1              
2             package R::YapRI::Interpreter::Perl;
3              
4 1     1   179423 use strict;
  1         2  
  1         161  
5 1     1   6 use warnings;
  1         1  
  1         35  
6 1     1   5 use autodie;
  1         2  
  1         8  
7              
8 1     1   7335 use Carp qw( carp croak cluck );
  1         3  
  1         163  
9 1     1   2259 use Math::BigFloat;
  1         29697  
  1         8  
10              
11             ## To export some functions
12              
13 1     1   952 use Exporter qw( import );
  1         3  
  1         1952  
14              
15             our @EXPORT_OK = qw( r_var );
16              
17             ###############
18             ### PERLDOC ###
19             ###############
20              
21             =head1 NAME
22              
23             R::YapRI::Interpreter.pm
24              
25             A module to transform perl variables into R command lines to define simple objs.
26              
27             =cut
28              
29             our $VERSION = '0.04';
30             $VERSION = eval $VERSION;
31              
32             =head1 SYNOPSIS
33              
34             use R::YapRI::Base;
35             use R::YapRI::Interpreter::Perl qw/r_var/;
36              
37             my $perl_var = [1, 2, 3];
38             my $r_var = r_var($perl_var);
39              
40              
41             =head1 DESCRIPTION
42              
43             A interpreter to translate Perl variables into R commands for L
44              
45             +==================+==============+===============================+
46             | PERL VARIABLE | R VARIABLE | Example |
47             +==================+==============+===============+===============+
48             | undef | NULL | $px = undef | rx <- NULL |
49             +------------------+--------------+---------------+---------------+
50             | empty ('' or "") | NA | $px = '' | rx <- NA |
51             +------------------+--------------+---------------+---------------+
52             | integer | numeric | $px = 12 | rx <- 12 |
53             +------------------+--------------+---------------+---------------+
54             | bigint,bigfloat | numeric | $px = '-1.2' | rx <- -1.2 |
55             +------------------+--------------+---------------+---------------+
56             | word 'TRUE' | TRUE | $px = 'TRUE' | rx <- TRUE |
57             +------------------+--------------+---------------+---------------+
58             | word 'FALSE' | FALSE | $px = 'FALSE' | rx <- FALSE |
59             +------------------+--------------+---------------+---------------+
60             | any other word | character | $px = "sun" | rx <- "sun" |
61             +------------------+--------------+---------------+---------------+
62             | ARRAY REF. | vector | $px = [1, 2] | rx <- c(1, 2) |
63             +------------------+--------------+---------------+---------------+
64             | HASH REF. | object | see below (*) |
65             +------------------+--------------+-------------------------------+
66            
67             * R object or R function without arguments
68              
69             $px = { a => undef }, will be just 'a'
70             $px = { mass => '' }, will be just 'mass'
71              
72             * R simple object with arguments
73              
74             $px = { '' => { x => 2 }}, will be 'x = 2'
75             $px = { '' => { x => [2, 4] }}, will be 'x = c(2, 4)
76              
77             * R functions with arguments
78              
79             $px = { log => 2 }, will be 'log(2)'
80             $px = { log => [2, { base => 10 }] }, will be 'log(2, base = 10 )'
81             $px = { t => {x => ''} }, will be 't(x)'
82             $px = { plot => [{ x => ''}, { main => "TEST"} ]}, will be:
83             plot(x, main = "TEST")
84              
85             Use array ref. to order the arguments in a function.
86              
87             Use hash ref keys to define an argument in an R function
88              
89             For more complex data structures, use L.
90            
91              
92             =head1 AUTHOR
93              
94             Aureliano Bombarely
95              
96              
97             =head1 CLASS METHODS
98              
99             The following class methods are implemented:
100              
101             =cut
102              
103              
104             #################################
105             ## VARIABLE CONVERSION METHODS ##
106             #################################
107              
108              
109             =head2 _rvar_noref
110              
111             Usage: my $r_string = _r_var_noref($perl_var);
112              
113             Desc: Internal function to parse a single non-reference perl variable
114             (scalar). Equivalence table:
115            
116             +==================+==============+=============================+
117             | PERL VARIABLE | R VARIABLE | Example |
118             +==================+==============+===============+=============+
119             | undef | NULL | $px = undef | rx <- NULL |
120             +------------------+--------------+---------------+-------------+
121             | empty ('' or "") | NA | $px = '' | rx <- NA |
122             +------------------+--------------+---------------+-------------+
123             | integer | numeric | $px = 12 | rx <- 12 |
124             +------------------+--------------+---------------+-------------+
125             | bigint,bigfloat | numeric | $px = '-1.2' | rx <- -1.2 |
126             +------------------+--------------+---------------+-------------+
127             | word 'TRUE' | TRUE | $px = 'TRUE' | rx <- TRUE |
128             +------------------+--------------+---------------+-------------+
129             | word 'FALSE' | FALSE | $px = 'FALSE' | rx <- FALSE |
130             +------------------+--------------+---------------+-------------+
131             | any other word | character | $px = "sun" | rx <- "sun" |
132             +------------------+--------------+---------------+-------------+
133              
134             Ret: $r_string, a scalar with the perl2R variable translation
135              
136             Args: $perl_var, could be, a scalar or an array reference
137              
138             Side_Effects: Die if is used a perl reference.
139              
140             Example: my $rvar = _rvar_noref(12);
141              
142             =cut
143              
144             sub _rvar_noref {
145 32     32   971 my $pvar = shift;
146              
147 32         37 my $rvar;
148            
149 32 100       55 if (defined $pvar) {
150 31 100       57 if (ref($pvar)) {
151 1         15 croak("ERROR: $pvar is a perl reference, unable to convert to R.");
152             }
153             else {
154 30 100       84 if ($pvar =~ m/./) {
155 28         129 my $mbf = Math::BigFloat->new($pvar);
156 28 100       2809 if ($mbf->is_nan()) {
157 11 100       98 if ($pvar =~ m/^(TRUE|FALSE)$/) {
158 4         17 $rvar = $pvar;
159             }
160             else {
161 7         32 $rvar = '"' . $pvar .'"';
162             }
163             }
164             else {
165 17         143 $rvar = $mbf->bstr();
166             }
167             }
168             else {
169 2         5 $rvar = 'NA';
170             }
171             }
172             }
173             else {
174 1         3 $rvar = 'NULL';
175             }
176 31         885 return $rvar;
177             }
178              
179             =head2 _rvar_vector
180              
181             Usage: my $r_arg = _rvar_vector($arrayref);
182              
183             Desc: Internal function to convert an perl array into a R vector
184              
185             Ret: $r_arg, a scalar with the perl2R variable translation
186              
187             Args: $arrayref, with the argument list
188              
189             Side_Effects: Die if the argument is not an arrayref.
190              
191             Example: my $r_vector = _rvar_vector($arrayref);
192              
193             =cut
194              
195             sub _rvar_vector {
196 8   33 8   1009 my $aref = shift ||
197             croak("ERROR: No array ref. was supplied to _rvar_vector");
198              
199 8         13 my $rvect;
200 8 100       22 if (ref($aref) eq 'ARRAY') {
201 7         13 my @list = ();
202 7         8 foreach my $el (@{$aref}) {
  7         16  
203 16         37 push @list, _rvar_noref($el);
204             }
205 7         31 $rvect = 'c(' . join(', ', @list) . ')';
206             }
207             else {
208 1         14 croak("ERROR: $aref supplied to _rvar_vector isnt an array ref.")
209             }
210 7         15 return $rvect;
211             }
212              
213              
214              
215             =head2 _rvar_arg
216              
217             Usage: my $r_arg = _rvar_arg($hashref);
218              
219             Desc: Internal function to convert an argument in a function in the following
220             way:
221             2 ===> '2'
222             'YES' ===> '"YES"'
223             [2, 3] ===> 'c(2, 3)'
224             { x => undef } ===> 'x'
225             { type => "p" } ===> 'type = "p"'
226             { col => ["blue", "green"]} ===> 'col = c("blue", "green")'
227             { labels => { x => undef } } ===> 'labels = x'
228              
229             Something different from that, will die.
230              
231             Ret: $r_arg, a scalar with the perl2R variable translation
232              
233             Args: $hashref, with the argument list
234              
235             Side_Effects: Die if the argument is not: scalar, array ref or a hash
236             reference.
237              
238             Example: my $arg = _rvar_arg({ type => "p" });
239              
240             =cut
241              
242             sub _rvar_arg {
243 13     13   1011 my $parg = shift;
244              
245 13         16 my $rarg;
246 13 50       23 if (defined $parg) {
247 13 100       29 if (ref($parg)) {
248 12 100       49 if (ref($parg) eq 'ARRAY') {
    50          
249 1         5 $rarg = _rvar_vector($parg);
250             }
251             elsif (ref($parg) eq 'HASH') {
252 11         17 my @list = ();
253 11         14 foreach my $k (sort keys %{$parg}) {
  11         46  
254 13 100 100     113 if (defined $parg->{$k} && $parg->{$k} =~ m/./) {
255 9         34 my $sarg = $k . ' = ';
256 9 50       38 if (ref($parg->{$k}) eq 'HASH') {
    100          
257 0         0 $sarg .= join(',', keys %{$parg->{$k}});
  0         0  
258             }
259             elsif (ref($parg->{$k}) eq 'ARRAY') {
260 2         7 $sarg .= _rvar_vector($parg->{$k});
261             }
262             else {
263 7 100       18 if (ref($parg->{$k})) {
264 1         11 croak("ERROR: No permited value for R arg.");
265             }
266 6         17 $sarg .= _rvar_noref($parg->{$k});
267             }
268 8         25 push @list, $sarg;
269             }
270             else {
271 4         13 push @list, $k;
272             }
273             }
274 10         43 $rarg = join(', ', @list);
275             }
276             }
277             else {
278 1         4 $rarg = _rvar_noref($parg);
279             }
280             }
281             else {
282 0         0 $rarg = 'NULL';
283             }
284 12         27 return $rarg
285             }
286              
287              
288              
289             =head2 r_var
290              
291             Usage: my $r_string = r_var($perl_var);
292              
293             Desc: Parse a perl variable and return a string with the r variable format,
294             For perl-non reference variables, see _rvar_noref
295              
296             +==================+=================+==============================+
297             | PERL VARIABLE | R VARIABLE | Example |
298             +==================+=================+==============+===============+
299             | ARRAY REF. | vector | $px = [1, 2] | rx <- c(1, 2) |
300             +------------------+-----------------+--------------+---------------+
301             | HASH REF. | object/function | see below |
302             +------------------+-----------------+------------------------------+
303            
304             * R object or R function without arguments
305              
306             $px = { a => undef }, will be just 'a'
307             $px = { mass => '' }, will be just 'mass'
308              
309             * R simple object with arguments
310              
311             $px = { '' => { x => 2 }}, will be 'x = 2'
312             $px = { '' => { x => [2, 4] }}, will be 'x = c(2, 4)
313              
314             * R functions with arguments
315              
316             $px = { log => 2 }, will be 'log(2)'
317             $px = { log => [2, { base => 10 }] }, will be 'log(2, base = 10 )'
318             $px = { t => {x => ''} }, will be 't(x)'
319             $px = { plot => [{ x => ''}, { main => "TEST"} ]}, will be:
320             plot(x, main = "TEST")
321              
322             Use array ref. to order the arguments in a function.
323             Use hash ref keys to define an argument in an R function
324              
325              
326             Ret: $r_string, a scalar with the perl2R variable translation
327              
328             Args: $perl_var, could be, a scalar or an array reference
329              
330             Side_Effects: Die if the reference used is not a ARRAY REF or HASH REF.
331              
332             Example: my $rvar = r_var([1, 2, 3, "TRUE", "last word"]);
333              
334             =cut
335              
336             sub r_var {
337 25     25 1 1439 my $pvar = shift;
338              
339 25         29 my $rvar;
340              
341 25         30 my $err = "isnt a scalar, ARRAYEF or HASHREF. Unable to convert to R.";
342 25 100       49 if (defined $pvar) {
343 24 100       59 unless (ref($pvar)) {
344 7         16 $rvar = _rvar_noref($pvar);
345             }
346             else {
347 17 100       58 if (ref($pvar) eq 'ARRAY') {
    100          
348 4         34 $rvar = _rvar_vector($pvar);
349             }
350             elsif (ref($pvar) eq 'HASH') { ## First level objects or functions
351            
352 12         22 my @list = ();
353 12         16 foreach my $obj (sort keys %{$pvar}) {
  12         61  
354 13         17 my $subvar = $obj;
355 13         22 my $args = $pvar->{$obj}; ## Second level, arguments
356            
357 13 100 100     140 if (defined $args && $args =~ m/./) {
358              
359 11 100       51 if ($obj =~ m/./) {
360 9         20 $subvar .= '(';
361             }
362              
363 11 100       24 unless (ref($args)) { ## Just numeric, char...
364 1         5 $subvar .= _rvar_noref($args);
365             }
366             else {
367 10         16 my @arglist = ();
368              
369 10 100       34 if (ref($args) eq 'ARRAY') { ## Ordered by user
    100          
370            
371 3         4 foreach my $arg (@{$args}) {
  3         7  
372 6         21 my $targ = _rvar_arg($arg);
373 6 50 33     57 if (defined $targ && $targ =~ m/./) {
374 6         17 push @arglist, $targ;
375             }
376             }
377             }
378             elsif (ref($args) eq 'HASH') { ## No ordered
379 6         13 my $targs = _rvar_arg($args);
380 6 50 33     42 if (defined $targs && $targs =~ m/./) {
381 6         12 push @arglist, $targs;
382             }
383             }
384             else {
385 1         5 croak("ERROR: $args $err");
386             }
387 9         26 $subvar .= join(', ', @arglist);
388             }
389            
390 10 100       34 if ($obj =~ m/./) {
391 8         14 $subvar .= ')'; ## Close list of arguments
392             }
393             }
394 12         20 push @list, $subvar;
395            
396             ## If there are more than one function or object
397              
398 12         45 $rvar = join('; ', @list);
399             }
400             }
401             else {
402 1         37 croak("ERROR: $pvar $err");
403             }
404             }
405             }
406             else { ## Perl variable undef will be R variable 'NULL'
407 1         4 $rvar = 'NULL';
408             }
409              
410 23         129 return $rvar;
411             }
412              
413              
414             =head1 ACKNOWLEDGEMENTS
415              
416             Lukas Mueller
417              
418             Robert Buels
419              
420             Naama Menda
421              
422             Jonathan "Duke" Leto
423              
424             =head1 COPYRIGHT AND LICENCE
425              
426             Copyright 2011 Boyce Thompson Institute for Plant Research
427              
428             Copyright 2011 Sol Genomics Network (solgenomics.net)
429              
430             This program is free software; you can redistribute it and/or
431             modify it under the same terms as Perl itself.
432              
433             =cut
434              
435              
436             ####
437             1; #
438             ####