Skip to content

Commit c726e7a

Browse files
mohawk2mohawk2
committed
zap approx from t/pdl_from_string.t - #34 
1 parent 4c9fb4d commit c726e7a

File tree

1 file changed

+79
-217
lines changed

1 file changed

+79
-217
lines changed

‎t/pdl_from_string.t‎

Lines changed: 79 additions & 217 deletions
Original file line numberDiff line numberDiff line change
@@ -11,11 +11,12 @@ use warnings;
1111
use Test::More;
1212
use Config;
1313
use PDL::LiteF;
14+
use Test::PDL;
1415

15-
isa_ok( pdl("[1,2]"), "PDL", qq{pdl("[1,2]") returns an ndarray} );
16+
isa_ok pdl("[1,2]"), "PDL", qq{pdl("[1,2]") returns an ndarray};
1617

1718
# Basic Tests #
18-
ok( all(pdl([1,2])==pdl("[1,2]")), qq{pdl(ARRAY REF) equals pdl("ARRAY REF")});
19+
is_pdl pdl([1,2]), pdl("[1,2]"), qq{pdl(ARRAY REF) equals pdl("ARRAY REF")};
1920
my $compare = pdl([
2021
[1, 0, 8],
2122
[6, 3, 5],
@@ -30,25 +31,15 @@ my $test_string = <<EOPDL;
3031
[2, 4, 2],
3132
]
3233
EOPDL
33-
my $t1 = pdl $test_string;
34-
ok(all(approx($t1, $compare)), "properly interprets good PDL input string");
34+
is_pdl pdl($test_string), $compare, "properly interprets good PDL input string";
3535
# See what happens when we remove the end commas
3636
$test_string =~ s/\],/]/g;
37-
my $t2 = pdl $test_string;
38-
ok(all(approx($t2, $compare)), "properly interprets good PDL input string sans ending commas");
39-
my $t3 = pdl '[1, 0, 8; 6, 3, 5; 3, 0, 5; 2, 4, 2]';
40-
ok(all(approx($t3, $compare)), "properly handles semicolons");
41-
my $t4 = pdl "$compare";
42-
ok(all(approx($t4, $compare)), "properly interprets good PDL output string");
43-
my $expected = pdl(1.2e3);
44-
my $got = pdl q[1.2e3];
45-
is($got, $expected, "Correctly interprets [1.2e3]");
46-
$expected = pdl(1.2e3, 4, 5.6e-7);
47-
$got = pdl q[1.2e3 4 5.6e-7];
48-
ok(all($got == $expected), "Correctly interprets [1.2e3 4 5.6e-7]");
49-
$expected = pdl(1.2e3, 4, 5.e-7);
50-
$got = pdl q[1.2e3 4 5.e-7];
51-
ok(all($got == $expected), "Correctly interprets [1.2e3 4 5.e-7]");
37+
is_pdl pdl($test_string), $compare, "properly interprets good PDL input string sans ending commas";
38+
is_pdl pdl('[1, 0, 8; 6, 3, 5; 3, 0, 5; 2, 4, 2]'), $compare, "properly handles semicolons";
39+
is_pdl pdl("$compare"), $compare, "properly interprets good PDL output string";
40+
is_pdl pdl(q[1.2e3]), pdl(1.2e3), "Correctly interprets [1.2e3]";
41+
is_pdl pdl(q[1.2e3 4 5.6e-7]), pdl(1.2e3, 4, 5.6e-7), "Correctly interprets [1.2e3 4 5.6e-7]";
42+
is_pdl pdl(q[1.2e3 4 5.e-7]), pdl(1.2e3, 4, 5.e-7), "Correctly interprets [1.2e3 4 5.e-7]";
5243

5344
for (
5445
'[i 1-i]',
@@ -73,171 +64,80 @@ for (
7364

7465
# Signs and operators #
7566
# Now some more interesting tests
76-
my $t5 = pdl "[1 -4]";
77-
$compare = pdl [1, -4];
78-
ok(all(approx($t5, $compare)), "properly identifies negative numbers with white-space separation");
67+
is_pdl pdl("[1 -4]"), pdl([1, -4]), "properly identifies negative numbers with white-space separation";
7968

80-
my $t6 = pdl "[1 - 4]";
81-
$compare = pdl [1,-4];
82-
ok(all(approx($t6, $compare)), "properly affixes negation operator to right operand");
69+
is_pdl pdl("[1 - 4]"), pdl([1,-4]), "properly affixes negation operator to right operand";
8370

84-
ok(all(approx(pdl("[1 - .4]"), pdl([1,-0.4]))), "properly handles decimals");
71+
is_pdl pdl("[1 - .4]"), pdl([1,-0.4]), "properly handles decimals";
8572

8673
my $t8 = pdl <<EOPDL;
8774
[
8875
[1,2,3; 4,-5,6]
8976
[7 +8, 8 + 9; 10, - .11, 12e3]
9077
]
9178
EOPDL
92-
9379
$compare = pdl([[[1,2,3], [4,-5,6]],[[7,8,8,9],[10,-.11,12e3]]]);
94-
ok(all(approx($t8, $compare)), "properly handles all sorts of stuff!");
80+
is_pdl $t8, $compare, "properly handles all sorts of stuff!";
9581

96-
$compare = pdl [1,2,-5];
97-
my $t9 = pdl '[1 + 2 - 5]';
98-
ok(all(approx($t9, $compare)), "Another operator check for pdl_from_string");
82+
is_pdl pdl('[1 + 2 - 5]'), pdl([1,2,-5]), "Another operator check for pdl_from_string";
9983

100-
$compare = pdl [1, 2, -5];
101-
my $t10 = pdl '[1 +2 -5]';
102-
ok(all(approx($t10, $compare)), "Yet another operator check for pdl_from_string");
84+
is_pdl pdl('[1 +2 -5]'), pdl([1, 2, -5]), "Yet another operator check for pdl_from_string";
10385

10486
#######################################
105-
# Semicolons as column seperators - 2 #
87+
# Semicolons as row seperators - 2 #
10688
#######################################
107-
108-
$compare = pdl [[1], [2], [3]];
109-
my $t11 = pdl '[1;2;3]';
110-
ok(all(approx($t11, $compare)), "column check");
111-
112-
$compare = pdl([[1,2,3],[4,5,6]]);
113-
my $t12 = pdl q[1 2 3; 4 5 6];
114-
ok(all(approx($t12, $compare)), "implicit bracketing check");
89+
is_pdl pdl('[1;2;3]'), pdl([[1], [2], [3]]), "column check";
90+
is_pdl pdl('1 2 3;4 5 6'), pdl([[1,2,3],[4,5,6]]), "implicit bracketing check";
11591

11692
##################################
11793
# Implicit bracketing checks - 9 #
11894
##################################
11995

12096
$compare = pdl([1,2,3,4]);
121-
my $t13 = pdl q[1 2 3 4];
122-
my $t14 = pdl q[1,2,3,4];
123-
my $t15 = pdl '[1 2 3 4]';
124-
my $t16 = pdl '[1,2,3,4]';
125-
126-
ok(all(approx($t13, $compare)), "Double-check implicit bracketing - no brackets");
127-
ok(all(approx($t14, $compare)), "Double-check implicit bracketing - no brackets and commas");
128-
ok(all(approx($t15, $compare)), "Double-check implicit bracketing - brackets");
129-
ok(all(approx($t16, $compare)), "Double-check implicit bracketing - brackets and commas");
130-
131-
# check dimensions of tests
132-
ok($t13->ndims == 1, "Implicit bracketing gets proper number of dimensions - no brackets, no commas");
133-
ok($t14->ndims == 1, "Implicit bracketing gets proper number of dimensions - no brackets, commas");
134-
ok($t15->ndims == 1, "Implicit bracketing gets proper number of dimensions - brackets, no commas");
135-
ok($t16->ndims == 1, "Implicit bracketing gets proper number of dimensions - brackets and commas");
136-
137-
$expected = pdl [];
138-
$got = pdl q[];
139-
ok(all($got == $expected), 'Blank strings are interpreted as empty arrays');
140-
# This generates an annoying warning, and the ndarray should be Empty anyway
141-
#$expected = pdl [];
142-
$got = pdl q[[]];
143-
ok(all($got == $expected), 'Empty bracket is correctly interpreted');
97+
is_pdl pdl(q[1 2 3 4]), $compare, "Double-check implicit bracketing - no brackets";
98+
is_pdl pdl(q[1,2,3,4]), $compare, "Double-check implicit bracketing - no brackets and commas";
99+
is_pdl pdl('[1 2 3 4]'), $compare, "Double-check implicit bracketing - brackets";
100+
is_pdl pdl('[1,2,3,4]'), $compare, "Double-check implicit bracketing - brackets and commas";
144101

145-
# Bad, inf, nan checks #
146-
my $bad_values = pdl q[nan inf -inf bad];
147-
148-
ok $bad_values->at(0) != $bad_values->at(0), 'properly handles nan'
149-
or diag("Zeroeth bad value should be nan but it describes itself as "
150-
. $bad_values->at(0));
151-
# inf test: inf == inf but inf * 0 != 0
152-
ok(( $bad_values->at(1) == $bad_values->at(1)
153-
and $bad_values->at(1) * 0.0 != 0.0), 'properly handles inf')
154-
or diag("First bad value should be inf but it describes itself as " . $bad_values->at(1));
155-
# inf test: -inf == -1 * inf
156-
ok(( $bad_values->at(2) == $bad_values->at(2)
157-
and $bad_values->at(2) * 0.0 != 0.0), 'properly handles -inf')
158-
or diag("Second bad value should be -inf but it describes itself as " . $bad_values->at(2));
159-
ok($bad_values->at(2) == -$bad_values->at(1), "negative inf is numerically equal to -inf");
160-
ok($bad_values->isbad->at(3), 'properly handles bad values')
161-
or diag("Third bad value should be BAD but it describes itself as " . $bad_values->slice(3));
162-
163-
my $infty = inf();
164-
my $min_inf = -inf();
165-
my $nan = nan();
166-
167-
my $bad = pdl 'bad';
168-
169-
ok $infty == $infty && $infty * 0.0 != 0.0, "pdl 'inf' works by itself"
170-
or diag "pdl 'inf' gave me $infty";
171-
ok $min_inf == $min_inf && $min_inf * 0.0 != 0.0, "pdl '-inf' works by itself"
172-
or diag "pdl '-inf' gave me $min_inf";
173-
ok($min_inf == -$infty, "pdl '-inf' == -pdl 'inf'");
174-
175-
ok(( $nan != $nan), "pdl 'nan' works by itself")
176-
or diag("pdl 'nan' gave me $nan");
102+
is_pdl pdl(q[]), pdl([]), 'Blank strings are interpreted as empty arrays';
103+
is_pdl pdl(q[[]]), pdl([]), 'Empty bracket is correctly interpreted';
177104

105+
# Bad, inf, nan checks #
106+
is_pdl pdl(q[nan inf -inf bad]), pdl(nan(), inf(), -inf(), pdl(0)->setbadif(1));
107+
my $infty = pdl('inf');
108+
my $min_inf = pdl('-inf');
109+
my $bad = pdl('bad');
110+
is_pdl $infty, inf(), "pdl 'inf' works by itself";
111+
is_pdl $min_inf, -inf(), "pdl '-inf' works by itself";
112+
is_pdl $min_inf, -$infty, "pdl '-inf' == -pdl 'inf'";
113+
is_pdl pdl('nan'), nan(), "pdl 'nan' works by itself";
178114
ok $bad->isbad, "pdl 'bad' works by itself"
179115
or diag "pdl 'bad' gave me $bad";
180116

181117
# Checks for windows strings:
182-
$infty = pdl q[1.#INF];
183-
$nan = pdl q[-1.#IND];
184-
185-
ok $infty == $infty && $infty * 0 != 0, "pdl '1.#INF' works"
186-
or diag "pdl '1.#INF' gave me $infty";
187-
ok $nan != $nan, "pdl '-1.#IND' works"
188-
or diag "pdl '-1.#IND' gave me $nan";
118+
is_pdl pdl(q[1.#INF]), inf(), "pdl '1.#INF' works";
119+
is_pdl pdl(q[-1.#IND]), nan(), "pdl '-1.#IND' works";
189120

190121
# Pi and e checks #
191-
$expected = pdl(1)->exp;
192-
# using approx() here since PDL only has support for double data
193-
# so there will be differences in the least significant places for
194-
# perls compiled with uselongdouble
195-
#
196-
$got = pdl q[e];
197-
ok(approx($got, $expected, 1e-12), 'q[e] returns exp(1)')
198-
or diag("Got $got");
199-
# using approx() here since PDL only has support for double data
200-
# so there will be differences in the least significant places for
201-
# perls compiled with uselongdouble
202-
#
203-
$got = pdl q[E];
204-
ok(approx($got, $expected, 1e-12), 'q[E] returns exp(1)')
205-
or diag("Got $got");
122+
my $expected = pdl(1)->exp;
123+
is_pdl pdl(q[e]), $expected, 'q[e] returns exp(1)';
124+
is_pdl pdl(q[E]), $expected, 'q[E] returns exp(1)';
206125
$expected = pdl(1, exp(1));
207-
$got = pdl q[1 e];
208-
ok(all($got == $expected), 'q[1 e] returns [1 exp(1)]')
209-
or diag("Got $got");
210-
$got = pdl q[1 E];
211-
ok(all($got == $expected), 'q[1 E] returns [1 exp(1)]')
212-
or diag("Got $got");
126+
is_pdl pdl(q[1 e]), $expected, 'q[1 e] returns [1 exp(1)]';
127+
is_pdl pdl(q[1 E]), $expected, 'q[1 E] returns [1 exp(1)]';
213128
$expected = pdl(exp(1), 1);
214-
$got = pdl q[e 1];
215-
ok(all($got == $expected), 'q[e 1] returns [exp(1) 1]')
216-
or diag("Got $got");
217-
$got = pdl q[E 1];
218-
ok(all($got == $expected), 'q[E 1] returns [exp(1) 1]')
219-
or diag("Got $got");
129+
is_pdl pdl(q[e 1]), $expected, 'q[e 1] returns [exp(1) 1]';
130+
is_pdl pdl(q[E 1]), $expected, 'q[E 1] returns [exp(1) 1]';
220131
$expected = pdl(1, exp(1), 2);
221-
$got = pdl q[1 e 2];
222-
ok(all($got == $expected), 'q[1 e 2] returns [1 exp(1) 2]')
223-
or diag("Got $got");
224-
$got = pdl q[1 E 2];
225-
ok(all($got == $expected), 'q[1 E 2] returns [1 exp(1) 2]')
226-
or diag("Got $got");
132+
is_pdl pdl(q[1 e 2]), $expected, 'q[1 e 2] returns [1 exp(1) 2]';
133+
is_pdl pdl(q[1 E 2]), $expected, 'q[1 E 2] returns [1 exp(1) 2]';
227134

228135
# Already checked all the permutations of e, so just make sure that it
229136
# properly substitutes pi
230137
$expected = pdl(1, 4 * atan2(1,1));
231-
$got = pdl q[1 pi];
232-
ok(all($got == $expected), 'q[1 pi] returns [1 4*atan2(1,1)]')
233-
or diag("Got $got");
234-
$got = pdl q[1 PI];
235-
ok(all($got == $expected), 'q[1 PI] returns [1 4*atan2(1,1)]')
236-
or diag("Got $got");
237-
$expected = pdl(4 * atan2(1,1), 1);
238-
$got = pdl q[pi 1];
239-
ok(all($got == $expected), 'q[pi 1] returns [4*atan2(1,1) 1]')
240-
or diag("Got $got");
138+
is_pdl pdl(q[1 pi]), $expected, 'q[1 pi] returns [1 4*atan2(1,1)]';
139+
is_pdl pdl(q[1 PI]), $expected, 'q[1 PI] returns [1 4*atan2(1,1)]';
140+
is_pdl pdl(q[pi 1]), pdl(4 * atan2(1,1), 1), 'q[pi 1] returns [4*atan2(1,1) 1]';
241141

242142
# Security checks #
243143
# Check croaking on arbitrary bare-words:
@@ -248,79 +148,43 @@ isnt($@, '', 'croaks with non-interpolated strings');
248148

249149
# Install a function that knows if it's been executed.
250150
{
251-
my $e_was_run = 0;
252-
sub PDL::Core::e { $e_was_run++ }
253-
sub PDL::Core::e123 { $e_was_run++ }
254-
my $to_check = q[1 e 2];
255-
eval {pdl $to_check};
256-
is($e_was_run, 0, "Does not execute local function e in [$to_check]");
257-
$e_was_run = 0;
258-
$to_check = q[1 +e 2];
259-
eval {pdl $to_check};
260-
is($e_was_run, 0, "Does not execute local function e in [$to_check]");
261-
$e_was_run = 0;
262-
$to_check = q[1 e+ 2];
263-
eval {pdl $to_check};
264-
is($e_was_run, 0, "Does not execute local function e in [$to_check]");
265-
$e_was_run = 0;
266-
$to_check = q[1e 2];
267-
eval {pdl $to_check};
268-
is($e_was_run, 0, "Does not execute local function e in [$to_check]");
269-
$e_was_run = 0;
270-
$to_check = q[1e+ 2];
271-
eval {pdl $to_check};
272-
is($e_was_run, 0, "Does not execute local function e in [$to_check]");
273-
$e_was_run = 0;
274-
$to_check = q[1+e 2];
275-
eval {pdl $to_check};
276-
is($e_was_run, 0, "Does not execute local function e in [$to_check]");
277-
$e_was_run = 0;
278-
$to_check = q[1+e+ 2];
279-
eval {pdl $to_check};
280-
is($e_was_run, 0, "Does not execute local function e in [$to_check]");
281-
$e_was_run = 0;
282-
$to_check = q[1 e123 2];
283-
eval {pdl $to_check};
284-
is($e_was_run, 0, "Does not execute local function e123 in [$to_check]");
285-
$e_was_run = 0;
151+
my $e_was_run = 0;
152+
sub PDL::Core::e { $e_was_run++ }
153+
sub PDL::Core::e123 { $e_was_run++ }
154+
for my $to_check (q[1 e 2], q[1 +e 2], q[1 e+ 2], q[1e 2], q[1e+ 2],
155+
q[1+e 2], q[1+e+ 2], q[1 e123 2]
156+
) {
157+
$e_was_run = 0;
158+
eval {pdl $to_check};
159+
is($e_was_run, 0, "Does not execute local function e in [$to_check]");
160+
}
286161
}
287162

288163
###############################
289164
# Useful croaking output - 36 #
290165
###############################
291166

292167
eval{ pdl q[1 l 3] };
293-
isnt($@, '', 'Croaks when invalid character is specified');
294-
like($@, qr/found disallowed character\(s\) 'l'/, 'Gives meaningful explanation of problem');
168+
like($@, qr/found disallowed character\(s\) 'l'/, 'good error when invalid character is specified');
295169
eval{ pdl q[1 po 3] };
296-
isnt($@, '', 'Croaks when invalid characters are specified');
297-
like($@, qr/found disallowed character\(s\) 'po'/, 'Gives meaningful explanation of problem');
170+
like($@, qr/found disallowed character\(s\) 'po'/, 'good error when invalid characters are specified');
298171

299172
# checks for croaking behavior for consecutive signs like +-2:
300173
eval{ pdl q[1 +-2 3] };
301-
like($@, qr/found a \w+ sign/, 'Good error when consecutive signs');
174+
like $@, qr/found a \w+ sign/, 'Good error when consecutive signs';
302175
eval{ pdl q[1 -+2 3] };
303-
like($@, qr/found a \w+ sign/, 'Good error when consecutive signs');
304-
305-
# 'larger word' croak checks (36)
306-
foreach my $special (qw(bad inf pi)) {
307-
foreach my $append (qw(2 e l)) {
308-
eval "pdl q[1 $special$append 2]";
309-
isnt($@, '', "Croaks when it finds $special$append");
310-
like($@, qr/larger word/, 'Gives meaningful explanation of problem');
311-
eval "pdl q[1 $append$special 2]";
312-
isnt($@, '', "Croaks when it finds $append$special");
313-
like($@, qr/larger word/, 'Gives meaningful explanation of problem');
314-
}
315-
}
316-
317-
# e croaks (6)
318-
my $special = 'e';
319-
foreach my $append (qw(2 e l)) {
320-
eval "pdl q[1 $special$append 2]";
321-
isnt($@, '', "Croaks when it finds $special$append");
322-
eval "pdl q[1 $append$special 2]";
323-
isnt($@, '', "Croaks when it finds $append$special");
176+
like $@, qr/found a \w+ sign/, 'Good error when consecutive signs';
177+
178+
foreach my $special (qw(bad inf pi e)) {
179+
foreach my $append (qw(2 e l)) {
180+
for my $str ("$special$append", "$append$special") {
181+
eval {pdl qq[1 $str 2]};
182+
my $re = $str eq 'e2' ? qr/exponentiation/ :
183+
$str eq '2e' ? qr/Incorrect/ :
184+
qr/larger word/;
185+
like $@, $re, "Good error for '$str'";
186+
}
187+
}
324188
}
325189

326190
## Issue information
@@ -343,15 +207,13 @@ my $cases = {
343207
q|[BAD BAD]| => q|[BAD BAD]|,
344208
q|[ BAD BAD ]| => q|[BAD BAD]|,
345209
};
346-
347210
while( my ($case_string, $expected_string) = each %$cases ) {
348-
my $bad_pdl = pdl( $case_string );
349-
subtest "Testing case: $case_string" => sub {
350-
ok( $bad_pdl->badflag, 'has badflag enabled');
351-
ok( $bad_pdl->isbad->all, 'all values in PDL are BAD');
352-
353-
is($bad_pdl->string, $expected_string, "PDL stringifies back to input string: @{[ $bad_pdl->string ]}");
354-
};
211+
my $bad_pdl = pdl( $case_string );
212+
subtest "Testing case: $case_string" => sub {
213+
ok $bad_pdl->badflag, 'has badflag enabled';
214+
ok $bad_pdl->isbad->all, 'all values in PDL are BAD';
215+
is $bad_pdl->string, $expected_string, "PDL stringifies ok";
216+
};
355217
}
356218

357219
is pdl(ushort, ['-5'])."", "[65531]", "ushort-typed ['-5'] converted right";

0 commit comments

Comments
 (0)