Skip to content

Commit

Permalink
add "contours" plot type
Browse files Browse the repository at this point in the history
  • Loading branch information
@mohawk2
mohawk2 committed May 11, 2024
1 parent c7c0654 commit 504cd91
Show file tree
Hide file tree
Showing 9 changed files with 135 additions and 65 deletions.
2 changes: 2 additions & 0 deletions Changes
View file
@@ -1,3 +1,5 @@
- add "contours" plot type

1.011 2024-04-22
- P{GPLOT,Lplot} to read devices using proper API not subprocesses
- if PDL_SIMPLE_ENGINE in ENV, use ONLY that if engine unspecified
Expand Down
2 changes: 1 addition & 1 deletion Makefile.PL
View file
Expand Up @@ -23,7 +23,7 @@ FOO
return $text;
}

my %prereq = ( 'PDL' => 0,
my %prereq = ( 'PDL' => '2.089', # contour_polylines
'File::Temp' => 0,
'Time::HiRes' => 0);

Expand Down
9 changes: 8 additions & 1 deletion README.pod
View file
Expand Up @@ -528,6 +528,11 @@ as they are interpreted as 8 bits per plane colour values. E.g.:
$image_data = rpic( 'my-image.png' )->mv(0,-1); # need RGB 3-dim last
$w->image( $image_data );

=item contours

As of 1.012. Draws contours. Takes a 2-D array of values, as (width x
height), and optionally a 1-D vector of contour values.

=item labels

This places text annotations on the plot. It requires three input
Expand Down Expand Up @@ -555,7 +560,7 @@ equivalent to C<plot> except it sets the plot option C<oplot>,
so that the plot will be overlain on the previous one.

=cut
=head2 line, points, image, imag
=head2 line, points, image, imag, cont

=for usage

Expand All @@ -582,6 +587,8 @@ it accepts up to three non-hash arguments at the start of the
argument list. The second and third are taken to be values for
the C<crange> plot option.

C<cont> resembles the PGPLOT function.

=cut
=head2 erase

Expand Down
113 changes: 66 additions & 47 deletions lib/PDL/Graphics/Simple.pm
View file
Expand Up @@ -277,10 +277,10 @@ $VERSION =~ s/_//g;
##############################
# Exporting
use base 'Exporter';
our @EXPORT = qw(pgswin line points imag hold release erase);
our @EXPORT = qw(pgswin line points imag cont hold release erase);
our @EXPORT_OK = (@EXPORT, qw(image plot));

our $API_VERSION = '1.011'; # PGS version where that API started
our $API_VERSION = '1.012'; # PGS version where that API started

##############################
# Configuration
Expand Down Expand Up @@ -689,6 +689,11 @@ as they are interpreted as 8 bits per plane colour values. E.g.:
$image_data = rpic( 'my-image.png' )->mv(0,-1); # need RGB 3-dim last
$w->image( $image_data );
=item contours
As of 1.012. Draws contours. Takes a 2-D array of values, as (width x
height), and optionally a 1-D vector of contour values.
=item labels
This places text annotations on the plot. It requires three input
Expand Down Expand Up @@ -739,6 +744,7 @@ our $plot_types = {
errorbars => { args=>[2,3], ndims=>[1] },
limitbars => { args=>[3,4], ndims=>[1] },
image => { args=>[1,3], ndims=>[2,3] },
contours => { args=>[1,2], ndims=>[2] },
labels => { args=>[3], ndims=>[1] },
};
our $plot_type_abbrevs = _make_abbrevs($plot_types);
Expand Down Expand Up @@ -903,7 +909,10 @@ sub _translate_plot {
barf "plot style $ptn requires $pt->{args}[0] or $pt->{args}[1] columns; you gave ".(0+@args)."\n"
if @args != $pt->{args}[0] and @args != $pt->{args}[1];

if (defined($pt->{args}[1])) { # Add an index variable if needed
if ($ptn eq 'contours' and @args == 1) {
my $cntr_cnt = 9;
push @args, zeroes($cntr_cnt)->xlinvals($args[-1]->minmax);
} elsif (defined($pt->{args}[1])) { # Add an index variable if needed
if ( $pt->{args}[1] - @args == 2 ) {
my @dims = ($args[0]->slice(":,:")->dims)[0,1];
unshift @args, xvals(@dims), yvals(@dims);
Expand All @@ -913,51 +922,57 @@ sub _translate_plot {
}
}

# Check that the PDL arguments all agree in a threading sense.
# Since at least one type of args has an array ref in there, we have to
# consider that case as a pseudo-PDL.
my $dims = do {
local $PDL::undefval = 1;
pdl([map [ ref($_) eq 'ARRAY' ? 0+@{$_} : $_->dims ], @args]);
};
my $dmax = $dims->mv(1,0)->maximum;
barf "Data dimensions do not agree in plot.\n"
unless ( ($dims==1) | ($dims==$dmax) )->all;

# Check that the number of dimensions is correct...
barf "Data dimension (".$dims->dim(0)."-D PDLs) is not correct for plot type $ptn (all dims=$dims)"
if $dims->dim(0) != $pt->{ndims}[0] and
(!defined($pt->{ndims}[1]) or $dims->dim(0) != $pt->{ndims}[1]);

if (@args > 1) {
# Accumulate x and y ranges...
my $dcorner = pdl(0,0);
# Deal with half-pixel offset at edges of images
if ($args[0]->dims > 1) {
my $xymat = pdl(
[ ($args[0]->slice("(1),(0)")-$args[0]->slice("(0),(0)")),
($args[0]->slice("(0),(1)")-$args[0]->slice("(0),(0)")) ],
[ ($args[1]->slice("(1),(0)")-$args[1]->slice("(0),(0)")),
($args[1]->slice("(0),(1)")-$args[1]->slice("(0),(0)")) ]
);
$dcorner = ($xymat x pdl(0.5,0.5)->slice("*1"))->slice("(0)")->abs;
}
for my $t ([0, qr/x/, $xminmax], [1, qr/y/, $yminmax]) {
my ($i, $re, $var) = @$t;
my @minmax = $args[$i]->minmax;
$minmax[0] -= $dcorner->at($i);
$minmax[1] += $dcorner->at($i);
if ($po->{logaxis} =~ $re) {
if ($minmax[1] > 0) {
$minmax[0] = $args[0]->where( ($args[0]>0) )->min if $minmax[0] <= 0;
} else {
$minmax[0] = $minmax[1] = undef;
if ($ptn eq 'contours') { # not supposed to be compatible
barf "Wrong dims for contours: need 2-D values, 1-D contour values"
unless $args[0]->ndims == 2 and $args[1]->ndims == 1;
($xminmax, $yminmax) = ([0, $args[0]->dim(0)-1], [0, $args[0]->dim(1)-1]);
} else {
# Check that the PDL arguments all agree in a threading sense.
# Since at least one type of args has an array ref in there, we have to
# consider that case as a pseudo-PDL.
my $dims = do {
local $PDL::undefval = 1;
pdl([map [ ref($_) eq 'ARRAY' ? 0+@{$_} : $_->dims ], @args]);
};
my $dmax = $dims->mv(1,0)->maximum;
barf "Data dimensions do not agree in plot.\n"
unless ( ($dims==1) | ($dims==$dmax) )->all;

# Check that the number of dimensions is correct...
barf "Data dimension (".$dims->dim(0)."-D PDLs) is not correct for plot type $ptn (all dims=$dims)"
if $dims->dim(0) != $pt->{ndims}[0] and
(!defined($pt->{ndims}[1]) or $dims->dim(0) != $pt->{ndims}[1]);

if (@args > 1) {
# Accumulate x and y ranges...
my $dcorner = pdl(0,0);
# Deal with half-pixel offset at edges of images
if ($args[0]->dims > 1) {
my $xymat = pdl(
[ ($args[0]->slice("(1),(0)")-$args[0]->slice("(0),(0)")),
($args[0]->slice("(0),(1)")-$args[0]->slice("(0),(0)")) ],
[ ($args[1]->slice("(1),(0)")-$args[1]->slice("(0),(0)")),
($args[1]->slice("(0),(1)")-$args[1]->slice("(0),(0)")) ]
);
$dcorner = ($xymat x pdl(0.5,0.5)->slice("*1"))->slice("(0)")->abs;
}
for my $t ([0, qr/x/, $xminmax], [1, qr/y/, $yminmax]) {
my ($i, $re, $var) = @$t;
my @minmax = $args[$i]->minmax;
$minmax[0] -= $dcorner->at($i);
$minmax[1] += $dcorner->at($i);
if ($po->{logaxis} =~ $re) {
if ($minmax[1] > 0) {
$minmax[0] = $args[0]->where( ($args[0]>0) )->min if $minmax[0] <= 0;
} else {
$minmax[0] = $minmax[1] = undef;
}
}
$var->[0] = $minmax[0] if defined($minmax[0])
and ( !defined($var->[0]) or $minmax[0] < $var->[0] );
$var->[1] = $minmax[1] if defined($minmax[1])
and ( !defined($var->[1]) or $minmax[1] > $var->[1] );
}
$var->[0] = $minmax[0] if defined($minmax[0])
and ( !defined($var->[0]) or $minmax[0] < $var->[0] );
$var->[1] = $minmax[1] if defined($minmax[1])
and ( !defined($var->[1]) or $minmax[1] > $var->[1] );
}
}

Expand Down Expand Up @@ -1024,7 +1039,7 @@ sub oplot {
plot(@_);
}

=head2 line, points, image, imag
=head2 line, points, image, imag, cont
=for usage
Expand All @@ -1051,6 +1066,8 @@ it accepts up to three non-hash arguments at the start of the
argument list. The second and third are taken to be values for
the C<crange> plot option.
C<cont> resembles the PGPLOT function.
=cut

sub _translate_convenience {
Expand Down Expand Up @@ -1089,6 +1106,8 @@ sub points { _convenience_plot( 'points', @_ ); }
sub image { _convenience_plot( 'image', @_, {called_from_imag=>1}); }
# Don't PDL-namespace image since it's so different from imag.

sub cont { _convenience_plot( 'contours', @_ ); }

sub _translate_imag {
my $me = &_invocant_or_global;
my $data = shift;
Expand Down
20 changes: 15 additions & 5 deletions lib/PDL/Graphics/Simple/Gnuplot.pm
View file
Expand Up @@ -16,14 +16,15 @@ use warnings;
use File::Temp qw/tempfile/;
use PDL::Options q/iparse/;
use PDL;
use PDL::ImageND; # for polylines
our $required_PGG_version = 1.5;

our $mod = {
shortname => 'gnuplot',
module=>'PDL::Graphics::Simple::Gnuplot',
engine => 'PDL::Graphics::Gnuplot',
synopsis=> 'Gnuplot 2D/3D (versatile; beautiful output)',
pgs_api_version=> '1.011',
pgs_api_version=> '1.012',
};
PDL::Graphics::Simple::register( $mod );

Expand Down Expand Up @@ -258,17 +259,27 @@ our $curve_types = {
$co->{with} = "lines";
return [ $co, $dx, $dy ];
},
contours => sub {
my ($me, $po, $co, $vals, $cvals) = @_;
$co->{with} = "lines";
$co->{style} //= 6; # so all contour parts have same style, blue somewhat visible against sepia
my @out;
for my $thresh ($cvals->list) {
my ($pi, $p) = contour_polylines($thresh, $vals, $vals->ndcoords);
next if $pi->at(0) < 0;
push @out, map [ $co, $_->dog ], path_segs($pi, $p->mv(0,-1));
}
@out;
},
labels => sub {
my($me, $po, $co, @data) = @_;
my $label_list = ($po->{label} or []);

for my $i(0..$data[0]->dim(0)-1) {
my $j = "";
my $s = $data[2]->[$i];
if ( $s =~ s/^([\<\>\| ])// ) {
$j = $1;
}

my @spec = ("$s", at=>[$data[0]->at($i), $data[1]->at($i)]);
push @spec,"left" if $j eq '<';
push @spec,"center" if $j eq '|';
Expand All @@ -278,8 +289,7 @@ our $curve_types = {
$po->{label} = $label_list;
$co->{with} = "labels";
return [ $co, [$po->{xrange}[0]], [$po->{yrange}[0]], [""] ];
}

},
};

sub plot {
Expand Down
3 changes: 2 additions & 1 deletion lib/PDL/Graphics/Simple/PGPLOT.pm
View file
Expand Up @@ -25,7 +25,7 @@ our $mod = {
module=>'PDL::Graphics::Simple::PGPLOT',
engine => 'PDL::Graphics::PGPLOT::Window',
synopsis=> 'PGPLOT (venerable but trusted)',
pgs_api_version=> '1.011',
pgs_api_version=> '1.012',
};
PDL::Graphics::Simple::register( $mod );
print $@;
Expand Down Expand Up @@ -167,6 +167,7 @@ our $pgplot_methods = {
$me->{obj}->errb($data->[0],$data->[1], $z, $z, -($data->[2]-$data->[1]), $data->[3]-$data->[1], $ppo);
},
'image' => 'imag',
'contours' => 'cont',
'circles'=> sub {
my ($me,$ipo,$data,$ppo) = @_;
$ppo->{filltype}='outline';
Expand Down
17 changes: 16 additions & 1 deletion lib/PDL/Graphics/Simple/PLplot.pm
View file
Expand Up @@ -25,7 +25,7 @@ our $mod = {
module=>'PDL::Graphics::Simple::PLplot',
engine => 'PDL::Graphics::PLplot',
synopsis=> 'PLplot (nice plotting, sloooow images)',
pgs_api_version=> '1.011',
pgs_api_version=> '1.012',
};
PDL::Graphics::Simple::register( $mod );

Expand Down Expand Up @@ -197,6 +197,21 @@ our $plplot_methods = {
PLOTTYPE=>'POINTS', SYMBOLSIZE=>0.0001, %$ppo);
$me->{obj}->xyplot($data->[0], $data->[1], PLOTTYPE=>'LINE', %$ppo);
},
contours => sub {
my ($me,$ipo,$data,$ppo) = @_;
my ($vals, $cvals) = @$data;
my $obj = $me->{obj};
plsstrm($obj->{STREAMNUMBER});
$obj->setparm(%$ppo);
pllsty($ppo->{LINESTYLE});
plwidth($ppo->{LINEWIDTH}) if $ppo->{LINEWIDTH};
my ($nx,$ny) = $vals->dims;
$obj->_setwindow;
$obj->_drawlabels;
my $grid = plAlloc2dGrid($vals->xvals, $vals->yvals);
plcont($vals, 1, $nx, 1, $ny, $cvals, \&pltr2, $grid);
plFree2dGrid($grid);
},
image => sub {
my ($me,$ipo,$data,$ppo) = @_;

Expand Down
24 changes: 19 additions & 5 deletions lib/PDL/Graphics/Simple/Prima.pm
View file
Expand Up @@ -21,6 +21,7 @@ package PDL::Graphics::Simple::Prima;
use strict;
use warnings;
use PDL;
use PDL::ImageND; # for polylines
use PDL::Options q/iparse/;
use File::Temp qw/tempfile/;

Expand All @@ -29,7 +30,7 @@ our $mod = {
module => 'PDL::Graphics::Simple::Prima',
engine => 'PDL::Graphics::Prima',
synopsis => 'Prima (interactive, fast, PDL-specific)',
pgs_api_version=> '1.011',
pgs_api_version=> '1.012',
};
PDL::Graphics::Simple::register( $mod );

Expand Down Expand Up @@ -246,8 +247,8 @@ sub DESTROY {
}

##############################
# Fake-o apply method makes sepiatone values for input data.
# We have to mock up an object method to match the style of PDL::Graphics::Prima::Palette,
# apply method makes sepiatone values for input data,
# to match the style of PDL::Graphics::Prima::Palette,
# in order to make the Matrix plot type happy (for 'with=>image').
@PDL::Graphics::Simple::Prima::Sepia_Palette::ISA = 'PDL::Graphics::Prima::Palette';
sub PDL::Graphics::Simple::Prima::Sepia_Palette::apply {
Expand Down Expand Up @@ -275,16 +276,29 @@ sub _load_types {

bins => sub {
my ($me, $plot, $block, $cprops) = @_;
my $x = $block->[0];
my ($x, $y) = @$block;
my $x1 = $x->range( [[0],[-1]], [$x->dim(0)], 'e' )->average;
my $x2 = $x->range( [[1],[0]], [$x->dim(0)], 'e' )->average;
my $newx = pdl($x1, $x2)->mv(-1,0)->clump(2)->sever;
my $y = $block->[1];
my $newy = $y->dummy(0,2)->clump(2)->sever;
$plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } =
ds::Pair($newx,$newy,plotType=>ppair::Lines(), @$cprops);
},

# as of 1.012, known to not draw all its lines(!) overplotting an image
# draws them all without an image in same plot() call, or separate plot()
contours => sub {
my ($me, $plot, $block, $cprops) = @_;
my ($vals, $cvals) = @$block;
for my $thresh ($cvals->list) {
my ($pi, $p) = contour_polylines($thresh, $vals, $vals->ndcoords);
next if $pi->at(0) < 0;
$plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } =
ds::Pair($_->dog, plotType=>ppair::Lines(), @$cprops)
for path_segs($pi, $p->mv(0,-1));
}
},

image => sub {
my ($me, $plot, $data, $cprops, $co, $ipo) = @_;
my ($xmin, $xmax) = $data->[0]->minmax;
Expand Down

0 comments on commit 504cd91

Please sign in to comment.