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
|
#!perl -T
use 5.010;
use strict;
use warnings FATAL => 'all';
use Test::More tests => 36;
use Test::Fatal;
use Statistics::R::REXP::Language;
use Statistics::R::REXP::Character;
use Statistics::R::REXP::Double;
use Statistics::R::REXP::Integer;
use Statistics::R::REXP::List;
use Statistics::R::REXP::Symbol;
my $language = Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('foo'), 4, 11.2]);
my $language2 = Statistics::R::REXP::Language->new([Statistics::R::REXP::Symbol->new('foo'), 4, 11.2]);
is($language, $language2, 'language equality');
is(Statistics::R::REXP::Language->new($language2), $language, 'copy constructor');
is(Statistics::R::REXP::Language->new(Statistics::R::REXP::List->new([Statistics::R::REXP::Symbol->new('foo'), 4, 11.2])),
$language, 'copy constructor from a vector');
## error checking in constructor arguments
like(exception {
Statistics::R::REXP::Language->new()
}, qr/The first element must be a Symbol or Language/,
'error-check in no-arg constructor');
like(exception {
Statistics::R::REXP::Language->new(elements => [])
}, qr/The first element must be a Symbol or Language/,
'error-check in empty vec constructor');
like(exception {
Statistics::R::REXP::Language->new(sub {1+1})
}, qr/Attribute 'elements' must be an array reference/,
'error-check in single-arg constructor');
like(exception {
Statistics::R::REXP::Language->new(1, 2, 3)
}, qr/odd number of arguments/,
'odd constructor arguments');
like(exception {
Statistics::R::REXP::Language->new([ {foo => 1, bar => 2} ])
}, qr/The first element must be a Symbol or Language/,
'bad call argument');
like(exception {
Statistics::R::REXP::Language->new(elements => {foo => 1, bar => 2})
}, qr/Attribute 'elements' must be an array reference/,
'bad elements argument');
my $another_language = Statistics::R::REXP::Language->new([Statistics::R::REXP::Symbol->new('bla'), 4, 11.2]);
isnt($language, $another_language, 'language inequality');
my $na_heavy_language = Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('bla'), ['', undef], '0']);
my $na_heavy_language2 = Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('bla'), [undef, undef], 0]);
is($na_heavy_language, $na_heavy_language, 'NA-heavy language equality');
isnt($na_heavy_language, $na_heavy_language2, 'NA-heavy language inequality');
is($language .'', 'language(symbol `foo`, 4, 11.2)', 'language text representation');
is(Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('foo'), undef]) .'',
'language(symbol `foo`, undef)', 'text representation of a singleton NA');
is(Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('bar'), [[undef]]]) .'',
'language(symbol `bar`, [[undef]])', 'text representation of a nested singleton NA');
is($na_heavy_language .'', 'language(symbol `bla`, [, undef], 0)', 'empty string representation');
is_deeply($language->elements,
[Statistics::R::REXP::Symbol->new('foo'), 4, 11.2], 'language contents');
is($language->elements->[2], 11.2, 'single element access');
is_deeply(Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('baz'), 4.0, '3x', 11])->elements,
[Statistics::R::REXP::Symbol->new('baz'), 4, '3x', 11], 'constructor with non-numeric values');
my $nested_language = Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('qux'), 4.0, ['b', ['cc', 44.1]], 11]);
is_deeply($nested_language->elements,
[Statistics::R::REXP::Symbol->new('qux'), 4, ['b', ['cc', 44.1]], 11], 'nested language contents');
is_deeply($nested_language->elements->[2]->[1], ['cc', 44.1], 'nested element');
is_deeply($nested_language->elements->[3], 11, 'non-nested element');
is($nested_language .'', 'language(symbol `qux`, 4, [b, [cc, 44.1]], 11)',
'nested language text representation');
my $nested_rexps = Statistics::R::REXP::Language->new([
Statistics::R::REXP::Symbol->new('quux'),
Statistics::R::REXP::Integer->new([ 1, 2, 3]),
Statistics::R::REXP::Language->new([
Statistics::R::REXP::Symbol->new('a'),
Statistics::R::REXP::Character->new(['b']),
Statistics::R::REXP::Double->new([11]) ]),
Statistics::R::REXP::Character->new(['foo']) ]);
is($nested_rexps .'',
'language(symbol `quux`, integer(1, 2, 3), language(symbol `a`, character(b), double(11)), character(foo))',
'nested language of REXPs text representation');
ok(! $language->is_null, 'is not null');
ok( $language->is_vector, 'is vector');
## attributes
is_deeply($language->attributes, undef, 'default attributes');
my $language_attr = Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('fred'), 3.3, '4', 11],
attributes => { foo => 'bar',
x => [40, 41, 42] });
is_deeply($language_attr->attributes,
{ foo => 'bar', x => [40, 41, 42] }, 'constructed attributes');
my $language_attr2 = Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('fred'), 3.3, '4', 11],
attributes => { foo => 'bar',
x => [40, 41, 42] });
my $another_language_attr = Statistics::R::REXP::Language->new(elements => [Statistics::R::REXP::Symbol->new('fred'), 3.3, '4', 11],
attributes => { foo => 'bar',
x => [40, 42, 42] });
is($language_attr, $language_attr2, 'equality considers attributes');
isnt($language_attr, $language, 'inequality considers attributes');
isnt($language_attr, $another_language_attr, 'inequality considers attributes deeply');
## attributes must be a hash
like(exception {
Statistics::R::REXP::Language->new(elements => [ Statistics::R::REXP::Symbol->new('foo') ],
attributes => 1)
}, qr/Attribute 'attributes' must be a hash reference/,
'setting non-HASH attributes');
## Perl representation
is_deeply($language->to_pl,
['foo', 4, 11.2],
'Perl representation');
is_deeply($na_heavy_language->to_pl,
['bla', ['', undef], '0'],
'language with NAs Perl representation');
is_deeply($nested_language->to_pl,
['qux', 4.0, ['b', ['cc', 44.1]], 11],
'nested languages Perl representation');
is_deeply($nested_rexps->to_pl,
[ 'quux', [ 1, 2, 3], [ 'a', ['b'], [11] ], ['foo'] ],
'language with nested REXPs Perl representation');
|
