Skip to content

Commit

Permalink
test PDL::string, make more consistent - fix #459
Browse files Browse the repository at this point in the history
  • Loading branch information
@mohawk2
mohawk2 committed Jan 30, 2024
1 parent f653c3c commit 2cd5775
Show file tree
Hide file tree
Showing 3 changed files with 86 additions and 118 deletions.
171 changes: 54 additions & 117 deletions Basic/Core/Core.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3271,7 +3271,10 @@ sub PDL::type { return PDL::Type->new($_[0]->get_datatype); }
=for ref
Convert ndarray to string, optionally using a C<sprintf> format.
Convert ndarray to string, optionally using a C<sprintf> format. If such
a format is provided, it is used. If not, then the formatting variables
in L</VARIABLES> provide a default, though heuristics are attempted to
make a nice-looking output.
=for usage
Expand Down Expand Up @@ -3770,128 +3773,62 @@ sub strND {
# String 1D array in nice format

sub str1D {
my($self,$format)=@_;
barf "Not 1D" if $self->getndims()!=1;
my $x = listref_c($self);
my ($ret,$dformat,$t);
$ret = "[";
my $dtype = $self->get_datatype();
$dformat = $PDL::floatformat if $dtype == $PDL_F;
$dformat = $PDL::doubleformat if $dtype == $PDL_D;
$dformat = $PDL::indxformat if $dtype == $PDL_IND;

my $badflag = $self->badflag();
for $t (@$x) {
if ( $badflag and $t eq "BAD" ) {
# do nothing
} elsif ($format) {
$t = sprintf $format,$t;
} else{ # Default
if ($dformat && length($t)>7) { # Try smaller
$t = sprintf $dformat,$t;
}
}
$ret .= $t.$sep;
}
my($self,$format)=@_;
barf "Not 1D" if $self->getndims != 1;
my $x = listref_c($self);
my $badflag = $self->badflag;
return "[".join($sep, map
$badflag && $_ eq "BAD" ? $_ :
$format ? sprintf $format,$_ : $_,
@$x)."]";
}

chop $ret; $ret.="]";
return $ret;
sub str_list {
my ($x, $row_len, $format, $dtype, $badflag) = @_;
my ($len, $findmax) = (0, 1);
if (!defined $format || $format eq "") {
# Format not given? - find max length of default
$len = max map length($_), @$x;
$format = "%".$len."s";
if ($len>7) { # Too long? - perhaps try smaller format
if ($dtype == $PDL_F) {
$format = $PDL::floatformat;
} elsif ($dtype == $PDL_D) {
$format = $PDL::doubleformat;
} elsif ($dtype == $PDL_IND) {
$format = $PDL::indxformat;
} else {
# Stick with default
$findmax = 0;
}
} else {
# Default ok
$findmax = 0;
}
}
$len = $badflag ?
max map $_ eq "BAD" ? 3 : length(sprintf $format,$_), @$x :
max map length(sprintf $format,$_), @$x
if $findmax; # Find max length of strings in final format
my @ret;
for (my $i=0; $i<=$#$x; $i+=$row_len) {
push @ret, "[".join($sep, map sprintf("%${len}s", $badflag && $_ eq "BAD" ? "BAD" : sprintf $format,$_), @$x[$i..$i+$row_len-1])."]";
}
return @ret;
}

# String 2D array in nice uniform format

sub str2D{
my($self,$format,$level)=@_;
my @dims = $self->dims();
barf "Not 2D" if scalar(@dims)!=2;
my $x = listref_c($self);
my ($i, $f, $t, $len, $ret);

my $dtype = $self->get_datatype();
my $badflag = $self->badflag();

my $findmax = 1;
if (!defined $format || $format eq "") {
# Format not given? - find max length of default
$len=0;

if ( $badflag ) {
for (@$x) {
if ( $_ eq "BAD" ) { $i = 3; }
else { $i = length($_); }
$len = $i>$len ? $i : $len;
}
} else {
for (@$x) {$i = length($_); $len = $i>$len ? $i : $len };
}

$format = "%".$len."s";

if ($len>7) { # Too long? - perhaps try smaller format
if ($dtype == $PDL_F) {
$format = $PDL::floatformat;
} elsif ($dtype == $PDL_D) {
$format = $PDL::doubleformat;
} elsif ($dtype == $PDL_IND) {
$format = $PDL::indxformat;
} else {
# Stick with default
$findmax = 0;
}
}
else {
# Default ok
$findmax = 0;
}
}

if($findmax) {
# Find max length of strings in final format
$len=0;

if ( $badflag ) {
for (@$x) {
if ( $_ eq "BAD" ) { $i = 3; }
else { $i = length(sprintf $format,$_); }
$len = $i>$len ? $i : $len;
}
} else {
for (@$x) {
$i = length(sprintf $format,$_); $len = $i>$len ? $i : $len;
}
}
} # if: $findmax

$ret = "\n" . " "x$level . "[\n";
{
my $level = $level+1;
$ret .= " "x$level ."[";
for ($i=0; $i<=$#$x; $i++) {

if ( $badflag and $$x[$i] eq "BAD" ) {
$f = "BAD";
} else {
$f = sprintf $format,$$x[$i];
}

$t = $len-length($f); $f = " "x$t .$f if $t>0;
$ret .= $f;
if (($i+1)%$dims[0]) {
$ret.=$sep;
}
else{ # End of output line
$ret.="]";
if ($i==$#$x) { # very last number
$ret.="\n";
}
else{
$ret.= $sep2."\n" . " "x$level ."[";
}
}
}
}
$ret .= " "x$level."]\n";
return $ret;
my($self,$format,$level)=@_;
my @dims = $self->dims();
barf "Not 2D" if scalar(@dims)!=2;
my $x = listref_c($self);
my @lines = str_list($x, $dims[0], $format, $self->get_datatype, $self->badflag);
my $ret = "\n" . " "x$level . "[\n";
$ret .= join $sep2."\n", map " "x($level+1).$_, @lines;
$ret .= "\n".(" "x$level)."]\n";
return $ret;
}

########## Docs for functions in Core.xs ##################
Expand Down
2 changes: 1 addition & 1 deletion Changes
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
- document PDL::string (#459) - thanks @vadim-160102 for report
- test, document PDL::string, make more consistent (#459) - thanks @vadim-160102 for report

2.085 2024-01-30
- switch FFT code to use heap, not VLA (#436) - thanks @HaraldJoerg for report
Expand Down
31 changes: 31 additions & 0 deletions t/core.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -131,6 +131,37 @@ isa_ok( PDL->topdl(1,2,3), "PDL", "topdl(1,2,3) returns an ndarray" );
$x=PDL->topdl(1,2,3);
ok (($x->nelem == 3 and all($x == pdl(1,2,3))), "topdl(1,2,3) returns a 3-ndarray containing (1,2,3)");

# stringification
{
my $x = sequence( 3 + 1e7 );
my $x_indx = which( $x > 1e7 - 4 );
is $x_indx.'', "[9999997 9999998 9999999 10000000 10000001 10000002]";
my $x_indx_bad = $x_indx->copy;
$x_indx_bad->setbadat($_) for 1, 4;
is $x_indx_bad.'', "[9999997 BAD 9999999 10000000 BAD 10000002]";
is +($x_indx - 10).'', "[9999987 9999988 9999989 9999990 9999991 9999992]";
is +($x_indx)->splitdim(0,3).'', "\n[\n [ 9999997 9999998 9999999]\n [ 10000000 10000001 10000002]\n]\n";
is +($x_indx - 10)->splitdim(0,3).'', "\n[\n [9999987 9999988 9999989]\n [9999990 9999991 9999992]\n]\n";
is +($x_indx_bad)->splitdim(0,3).'', "\n[\n [ 9999997 BAD 9999999]\n [ 10000000 BAD 10000002]\n]\n";
is +($x_indx_bad - 10)->splitdim(0,3).'', "\n[\n [9999987 BAD 9999989]\n [9999990 BAD 9999992]\n]\n";
my $x_double = where( $x, $x > 1e7 - 4 );
is $x_double.'', "[9999997 9999998 9999999 10000000 10000001 10000002]";
is +($x_double - 10).'', "[9999987 9999988 9999989 9999990 9999991 9999992]";
is +($x_double)->splitdim(0,3).'', "\n[\n [ 9999997 9999998 9999999]\n [ 10000000 10000001 10000002]\n]\n";
is +($x_double - 10)->splitdim(0,3).'', "\n[\n [9999987 9999988 9999989]\n [9999990 9999991 9999992]\n]\n";
my $x_long = where( long($x), $x > 1e7 - 4 );
is $x_long.'', "[9999997 9999998 9999999 10000000 10000001 10000002]";
is +($x_long - 10).'', "[9999987 9999988 9999989 9999990 9999991 9999992]";
is +($x_long)->splitdim(0,3).'', "\n[\n [ 9999997 9999998 9999999]\n [10000000 10000001 10000002]\n]\n";
is +($x_long - 10)->splitdim(0,3).'', "\n[\n [9999987 9999988 9999989]\n [9999990 9999991 9999992]\n]\n";
my $fracs = sequence(9) / 16;
is $PDL::doubleformat, "%10.8g";
is $fracs.'', "[0 0.0625 0.125 0.1875 0.25 0.3125 0.375 0.4375 0.5]";
is $fracs->string($PDL::doubleformat).'', "[ 0 0.0625 0.125 0.1875 0.25 0.3125 0.375 0.4375 0.5]";
local $PDL::doubleformat = '%8.2g';
is $fracs.'', "[0 0.0625 0.125 0.1875 0.25 0.3125 0.375 0.4375 0.5]";
is $fracs->string($PDL::doubleformat).'', "[ 0 0.062 0.12 0.19 0.25 0.31 0.38 0.44 0.5]";
}

# test $PDL::undefval support in pdl (bug #886263)
#
Expand Down

0 comments on commit 2cd5775

Please sign in to comment.