From 1a98b5e40e3582b6b9b59402d2262b2b1f48703d Mon Sep 17 00:00:00 2001 From: Ed J Date: Thu, 11 Apr 2024 18:21:18 +0100 Subject: [PATCH] PGS::Prima to only load Prima in check() --- lib/PDL/Graphics/Simple/Prima.pm | 223 ++++++++++++++----------------- 1 file changed, 103 insertions(+), 120 deletions(-) diff --git a/lib/PDL/Graphics/Simple/Prima.pm b/lib/PDL/Graphics/Simple/Prima.pm index c5d779d..a597dfa 100644 --- a/lib/PDL/Graphics/Simple/Prima.pm +++ b/lib/PDL/Graphics/Simple/Prima.pm @@ -7,8 +7,8 @@ ### ### See the PDL::Graphics::Simple docs for details ### -### Prima setup is borrowed from D. Mertens' PDL::Graphics::Prima::Simple -### +### Prima setup is borrowed from D. Mertens' PDL::Graphics::Prima::Simple +### ## # @@ -31,10 +31,9 @@ our $mod = { synopsis => 'Prima (interactive, fast, PDL-specific)', pgs_api_version=> '1.011', }; -eval { require PDL::Graphics::Prima; 1 } and - PDL::Graphics::Simple::register( $mod ); +PDL::Graphics::Simple::register( $mod ); -our (@colors, @patterns); +our (@colors, @patterns, $types); ########## # PDL::Graphics::Simple::Prima::check @@ -42,7 +41,7 @@ our (@colors, @patterns); sub check { my $force = shift; $force = 0 unless(defined($force)); - + return $mod->{ok} unless( $force or !defined($mod->{ok})); $mod->{ok} = 0; # makes default case simpler @@ -65,7 +64,7 @@ sub check { undef $@; return 0; } - + eval { require Prima::Application; Prima::Application->import(); @@ -86,7 +85,7 @@ sub check { require Prima::Edit; require Prima::Const; }; - if($@){ + if($@){ $mod->{msg} = "Couldn't load auxiliary Prima modules: ".$@; undef $@; return 0; @@ -100,6 +99,7 @@ sub check { lp::Solid(), lp::Dash(), lp::LongDash(), lp::ShortDash(), lp::DotDot(), lp::DashDot(), lp::DashDotDot(), ); + _load_types(); $mod->{ok} =1; return 1; @@ -124,7 +124,7 @@ sub new { $opt_in = {} unless(defined($opt_in)); my $opt = { iparse($new_defaults, $opt_in) }; - + unless( check() ) { die "$mod->{shortname} appears nonfunctional: $mod->{msg}\n" unless(check(1)); } @@ -133,22 +133,22 @@ sub new { my $pw = Prima::Window->create( text => $opt->{output} || "PDL/Prima Plot", size => [$size->[0], $size->[1]], - onCreate => sub { $PDL::Graphics::Prima::Simple::N_windows++; }, - onDestroy => sub { $PDL::Graphics::Prima::Simple::N_windows--; + onCreate => sub { $PDL::Graphics::Prima::Simple::N_windows++; }, + onDestroy => sub { $PDL::Graphics::Prima::Simple::N_windows--; PDL::Graphics::Prima::Simple::twiddling(0) if($PDL::Graphics::Prima::Simple::N_windows==0); - } - ); + } + ); die "Couldn't create a Prima window!" unless(defined($pw)); if($opt_in->{type} =~ m/^f/i) { $pw->hide; } my $me = { obj => $pw, - widgets => [], - next_plotno=>0, - multi=>$opt_in->{multi}, - type=>$opt->{type}, - output=>$opt->{output} + widgets => [], + next_plotno=>0, + multi=>$opt_in->{multi}, + type=>$opt->{type}, + output=>$opt->{output} }; return bless($me, "PDL::Graphics::Simple::Prima"); } @@ -171,7 +171,7 @@ sub DESTROY { if($@) { print $@; undef $@; - } + } } else { print STDERR "No plot was sent to $me->{output}\n"; } @@ -186,11 +186,11 @@ sub DESTROY { print STDERR "No plot was sent to $me->{output}\n"; } else { print STDERR "WARNING - multiplot support is experimental for the Prima engine\n"; - + my ($h,$tmpfile) = tempfile('PDL-Graphics-Simple-XXXX'); close $h; unlink($tmpfile); - + my $suffix; if($me->{output}=~ s/(\.\w{2,4})$//) { $suffix = $1; @@ -198,16 +198,16 @@ sub DESTROY { $suffix = ".png"; } $tmpfile .= $suffix; - + my $widget_dex = 0; my $im = undef; my $ztile = undef; ROW:for my $row(0..$me->{multi}->[1]-1) { my $imrow = undef; for my $col(0..$me->{multi}->[0]-1) { - + my $tile; - + if($widget_dex < @{$me->{widgets}}) { eval { $me->{widgets}->[$widget_dex++]->save_to_file($tmpfile) }; last ROW if($@); @@ -218,14 +218,14 @@ sub DESTROY { # ztile is always initialized by first run through... $tile = $ztile; } - + if(!defined($imrow)) { $imrow = $tile; } else { $imrow = $imrow->glue(0,$tile); } } # end of row loop - + if(!defined($im)) { $im = $imrow; } else { @@ -266,19 +266,19 @@ sub PDL::Graphics::Simple::Prima::Sepia_Palette::apply { my $g = ($min==$max)?$ data->zeroes : (($data->double - $min)/($max-$min))->clip(0,1); my $r = $g->sqrt; my $b = $g*$g; - + return (pdl($r,$g,$b)*255.999)->floor->mv(-1,0)->rgb_to_color; } - + ############################## # Plot types # -# This probably needs a little more smarts. +# This probably needs a little more smarts. # Currently each entry is either a ppair:: return or a sub that implements -# the plot type in terms of others. - -our $types = { +# the plot type in terms of others. +sub _load_types { + $types = { lines => q{ppair::Lines}, points => [ map { ppair->can($_)->() } qw/Blobs Triangles Squares Crosses Xs Asterisks/ ], @@ -289,67 +289,55 @@ our $types = { 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()}) } = + $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = ds::Pair($newx,$newy,plotType=>ppair::Lines(), @$cprops); }, - - image => sub { my($me, $plot, $data, $cprops, $co) = @_; - my ($xmin, $xmax) = $data->[0]->minmax; my $dx = 0.5 * ($xmax-$xmin) / ($data->[0]->dim(0) - (($data->[0]->dim(0)==1) ? 0 : 1)); $xmin -= $dx; $xmax += $dx; - my ($ymin, $ymax) = $data->[1]->minmax; my $dy = 0.5 * ($ymax-$ymin) / ($data->[0]->dim(1) - (($data->[1]->dim(1)==1) ? 0 : 1)); $ymin -= $dy; $ymax += $dy; - - $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = - ds::Grid($data->[2], + $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = + ds::Grid($data->[2], x_bounds=>[ $xmin, $xmax ], y_bounds=>[ $ymin, $ymax ], plotType=>pgrid::Matrix( palette => bless({crange=>$me->{ipo}->{crange},data=>$data,co=>$co},'PDL::Graphics::Simple::Prima::Sepia_Palette')), ); - if(!!$co->{wedge}) { print STDERR "Color wedges are not supported (yet) in Prima\n"; } }, - circles => sub { - my($me, $plot, $data, $cprops) = @_; - our $cstash; - unless(defined($cstash)) { - my $ang = PDL->xvals(362)*3.14159/180; - $cstash = {}; - $cstash->{c} = $ang->cos; - $cstash->{s} = $ang->sin; - $cstash->{s}->slice("361") .= $cstash->{c}->slice("361") .= PDL->pdl(1.1)->acos; # NaN - } - my $dr = $data->[2]->flat; - my $dx = ($data->[0]->flat->dummy(0,1) + $dr->dummy(0,1)*$cstash->{c})->flat; - my $dy = ($data->[1]->flat->dummy(0,1) + $dr->dummy(0,1)*$cstash->{s})->flat; - $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = - ds::Pair( $dx, $dy, plotType=>ppair::Lines(), @$cprops); + my($me, $plot, $data, $cprops) = @_; + our $cstash; + unless(defined($cstash)) { + my $ang = PDL->xvals(362)*3.14159/180; + $cstash = {}; + $cstash->{c} = $ang->cos; + $cstash->{s} = $ang->sin; + $cstash->{s}->slice("361") .= $cstash->{c}->slice("361") .= PDL->pdl(1.1)->acos; # NaN + } + my $dr = $data->[2]->flat; + my $dx = ($data->[0]->flat->dummy(0,1) + $dr->dummy(0,1)*$cstash->{c})->flat; + my $dy = ($data->[1]->flat->dummy(0,1) + $dr->dummy(0,1)*$cstash->{s})->flat; + $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = + ds::Pair( $dx, $dy, plotType=>ppair::Lines(), @$cprops); }, - labels => sub { my($me,$plot,$block,$cprops,$co) = @_; - my $x = $block->[0]->flat->sever; my $y = $block->[1]->flat->sever; my @labels = @{$block->[2]}; - my @lrc = (); for my $i(0..$x->dim(0)-1) { my $j =0; @@ -358,55 +346,51 @@ our $types = { if($ch =~ m/[\|\>]/) { my $tw = $plot->get_text_width($labels[$i]); $tw /= 2 if($ch eq '|'); - $x->slice("($i)") .= + $x->slice("($i)") .= $plot->x->pixels_to_reals( - $plot->x->reals_to_pixels( $x->slice("($i)") ) - $tw + $plot->x->reals_to_pixels( $x->slice("($i)") ) - $tw ); } } } - - $plot->dataSets()->{1+keys(%{$plot->dataSets()})} = + $plot->dataSets()->{1+keys(%{$plot->dataSets()})} = ds::Note( map { pnote::Text($labels[$_],x=>$x->slice("($_)"),y=>$y->slice("($_)")); } (0..$#labels) ); - } -}; - -$types->{limitbars} = sub { - # Strategy: make T-errorbars out of the x/y/height data and generate a Line - # plot. The T-errorbar width is 4x the LineWidth (+/- 2x). - my($me, $plot, $block, $cprops, $co) = @_; - my $x = $block->[0]->flat; - my $y = $block->[1]->flat; - my $ylo = $block->[2]->flat; - my $yhi = $block->[3]->flat; - - # Calculate T bar X ranges - my $of = ($co->{width}||1) * 2; - my $xp = $plot->x->reals_to_pixels($x); - my $xlo = $plot->x->pixels_to_reals( $xp - $of ); - my $xhi = $plot->x->pixels_to_reals( $xp + $of ); - my $nan = PDL->new_from_specification($x->dim(0)); $nan .= asin(pdl(1.1)); - - my $xdraw = pdl($xlo,$xhi,$x, $x, $xlo,$xhi,$nan)->mv(1,0)->flat; - my $ydraw = pdl($ylo,$ylo,$ylo,$yhi,$yhi,$yhi,$nan)->mv(1,0)->flat; - $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = - ds::Pair($xdraw,$ydraw,plotType=>ppair::Lines(), @$cprops); - $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = - ds::Pair($x,$y,plotType=>$types->{points}->[ ($me->{curvestyle}-1) %(0+@{$types->{points}}) ], @$cprops); -}; - + }, -$types->{errorbars} = sub { - # Strategy: make T-errorbars out of the x/y/height data and generate a Line - # plot. The T-errorbar width is 4x the LineWidth (+/- 2x). - my($me, $plot, $block, $cprops, $co) = @_; - my $halfwidth = $block->[2]->flat; - $block->[2] = $block->[1] - $halfwidth; - $block->[3] = $block->[1] + $halfwidth; - &{$types->{limitbars}}($me, $plot, $block, $cprops, $co); -}; + limitbars => sub { + # Strategy: make T-errorbars out of the x/y/height data and generate a Line + # plot. The T-errorbar width is 4x the LineWidth (+/- 2x). + my($me, $plot, $block, $cprops, $co) = @_; + my $x = $block->[0]->flat; + my $y = $block->[1]->flat; + my $ylo = $block->[2]->flat; + my $yhi = $block->[3]->flat; + # Calculate T bar X ranges + my $of = ($co->{width}||1) * 2; + my $xp = $plot->x->reals_to_pixels($x); + my $xlo = $plot->x->pixels_to_reals( $xp - $of ); + my $xhi = $plot->x->pixels_to_reals( $xp + $of ); + my $nan = PDL->new_from_specification($x->dim(0)); $nan .= asin(pdl(1.1)); + my $xdraw = pdl($xlo,$xhi,$x, $x, $xlo,$xhi,$nan)->mv(1,0)->flat; + my $ydraw = pdl($ylo,$ylo,$ylo,$yhi,$yhi,$yhi,$nan)->mv(1,0)->flat; + $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = + ds::Pair($xdraw,$ydraw,plotType=>ppair::Lines(), @$cprops); + $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = + ds::Pair($x,$y,plotType=>$types->{points}->[ ($me->{curvestyle}-1) %(0+@{$types->{points}}) ], @$cprops); + }, + errorbars => sub { + # Strategy: make T-errorbars out of the x/y/height data and generate a Line + # plot. The T-errorbar width is 4x the LineWidth (+/- 2x). + my($me, $plot, $block, $cprops, $co) = @_; + my $halfwidth = $block->[2]->flat; + $block->[2] = $block->[1] - $halfwidth; + $block->[3] = $block->[1] + $halfwidth; + &{$types->{limitbars}}($me, $plot, $block, $cprops, $co); + }, + }; +} ############################## @@ -422,14 +406,14 @@ sub plot { if(defined($ipo->{legend})) { printf(STDERR "WARNING: Ignoring 'legend' option (Legends not yet supported by PDL::Graphics::Simple::Prima v%s)",$PDL::Graphics::Simple::VERSION); } - + my $plot; - + if($ipo->{oplot} and defined($me->{last_plot})) { $plot = $me->{last_plot}; } else { $me->{curvestyle} = 0; - + if( $me->{multi} ) { # Multiplot - handle logic and plot placement @@ -462,39 +446,39 @@ sub plot { push(@{$me->{widgets}}, $plot); $me->{last_plot} = $plot; - + ## Set global plot options: titles, axis labels, and ranges. $plot->hide; $plot->lock; $plot->title( $ipo->{title} ) if(defined($ipo->{title})); $plot->x->label( $ipo->{xlabel} ) if(defined($ipo->{xlabel})); $plot->y->label( $ipo->{ylabel} ) if(defined($ipo->{ylabel})); - + $plot->x->scaling(sc::Log()) if($ipo->{logaxis}=~ m/x/i); $plot->y->scaling(sc::Log()) if($ipo->{logaxis}=~ m/y/i); - + $plot->x->min($ipo->{xrange}->[0]) if(defined($ipo->{xrange}) and defined($ipo->{xrange}->[0])); $plot->x->max($ipo->{xrange}->[1]) if(defined($ipo->{xrange}) and defined($ipo->{xrange}->[1])); $plot->y->min($ipo->{yrange}->[0]) if(defined($ipo->{yrange}) and defined($ipo->{yrange}->[0])); $plot->y->max($ipo->{yrange}->[1]) if(defined($ipo->{yrange}) and defined($ipo->{yrange}->[1])); - + ############################## - # I couldn't find a way to scale the plot to make the plot area justified, so + # I couldn't find a way to scale the plot to make the plot area justified, so # we cheat and adjust the axis values instead. # This is a total hack, but at least it produces justified plots. if( !!($ipo->{justify}) ) { my ($dmin,$pmin,$dmax,$pmax,$xscale,$yscale); - + ($dmin,$dmax) = $plot->x->minmax; $pmin = $plot->x->reals_to_pixels($dmin); $pmax = $plot->x->reals_to_pixels($dmax); $xscale = ($pmax-$pmin)/($dmax-$dmin); - + ($dmin,$dmax) = $plot->y->minmax; $pmin = $plot->y->reals_to_pixels($dmin); $pmax = $plot->y->reals_to_pixels($dmax); $yscale = ($pmax-$pmin)/($dmax-$dmin); - + my $ratio = $yscale / $xscale; print "ratio=$ratio\n"; if($ratio > 1) { @@ -517,24 +501,24 @@ sub plot { ############################## - # Rubber meets the road -- loop over data blocks and + # Rubber meets the road -- loop over data blocks and # ship out each curve to the appropriate dispatcher in the $types table for my $block(@_) { my $co = shift @$block; - + # Parse out curve style (for points type selection) if(defined($co->{style}) and $co->{style}) { $me->{curvestyle} = $co->{style}; } else { $me->{curvestyle}++; } - + my $cprops = [ color => $colors[ ($me->{curvestyle}-1) % @colors ], linePattern => $patterns[ ($me->{curvestyle}-1) % @patterns ], lineWidth => $co->{width} || 1 ]; - + my $type = $types->{$co->{with}}; if( ref($type) eq 'CODE' ) { &{$type}($me, $plot, $block, $cprops, $co); @@ -547,7 +531,7 @@ sub plot { } else { $pt = eval $type; } - + $plot->dataSets()->{ 1+keys(%{$plot->dataSets()}) } = ds::Pair(@$block, plotType => $pt, @$cprops); } } @@ -560,7 +544,7 @@ sub plot { $plot->hide; $me->{obj}->hide; } - + ############################## # Another lame kludge. Run the event loop for 50 milliseconds, to enable a redraw, # then exit it. @@ -571,7 +555,6 @@ sub plot { eval { no warnings 'once'; $::application->go }; die unless $@ =~ /^done with event loop/; undef $@; +} -} - 1;