view release on metacpan or  search on metacpan

lib/Chart/EPS_graph.pm  view on Meta::CPAN

	$self->{data}        = [];
	$self->{y1}          = [];
	$self->{y2}          = [];
	$self->{shown}       = [];
	$self->{not_shown}   = [];
	$self->{close_gap}   = 0;
	$self->{x_is_zeroth} = 1;
	$self->{x_scale}     = 1;
	$self->{ps_path}     = $EMPTY;
	$self->{verbosity}   = 1; # 0 = Quiet, 1 = Info, 2 = Diagnostic.
	bless $self, $class;
	return $self;
}

# Allow user to change defaults and input data.
sub set {
	ref( my $self = shift ) or croak 'Oops! Method set() is instance, not class.';
	my %user_defs = @_;
	while ( my ($key, $value) = each %user_defs ) {
		if ( exists $self->{$key}) {$self->{$key} = $value }
		else { carp "Oops! Key '$key' non-existant in hash '$self'.\n" }
	}                                             
	return 'Pthhht! to Perl::Critic';
}

# Make custom adjustments to default Prolog defs.
sub ps_defs_insert {
	ref( my $self = shift ) or croak 'Oops! Method ps_defs_insert() is instance, not class.';
	$self->chans_elect();
	my $str = ();

	$str .= "/bg_color ($self->{bg_color}) def \n";
	$str .= "/fg_color ($self->{fg_color}) def \n";
	$str .= '/web_colors [ ';
	for ( @{$self->{web_colors}} ) { $str .= "/$_ " }
	$str .= "] def \n";

	$str .= "/font_name /$self->{font_name} def \n";
	$str .= "/font_size $self->{font_size} def \n";


	# Set not-to-be-shown labels as empty strings.
	$str .= "/label_top ($self->{label_top}) def \n";
	$str .= "/label_y1 ($self->{label_y1}) def \n";
	$str .= "/label_y1_2 ($self->{label_y1_2}) def \n";
	$str .= "/label_y2 ($self->{label_y2}) def \n";
	$str .= "/label_y2_2 ($self->{label_y2_2}) def \n";
	$str .= "/label_x ($self->{label_x}) def \n";
	$str .= "/label_x_2 ($self->{label_x_2}) def \n";

	$str .= '/fake_col_zero_flag ';
	$str .= $self->{x_is_zeroth} ? 'false' : 'true';
	$str .= " def \n";

	$str .= "/fake_col_zero_scale $self->{x_scale} def \n";

	$str .= "/data_sets 1 def \n";

	# This is an ugly, ex-post-facto hack.
	# When chans skipped, patch up the bottom string to cover up remove gap in
	# channel ID's. In short, make legend ID match the gap-free curve ID.
	if ($self->{close_gap}) {
		$self->{shown} = [ @{ $self->{y1} }, @{ $self->{y2} } ];
		my @gap_free = gap_free_skip( $self->{shown}, $self->{not_shown} );
		for my $i ( 0 .. $#gap_free ) {
			$self->{label_x_proc} =~ s/  $self->{shown}->[$i] /  $gap_free[$i] /m;
			$self->{label_x_proc} =~ s/  $self->{shown}->[$i] show_color_id/ $gap_free[$i] show_color_id/m;
		}
	}

	$str .= $self->{label_x_proc}; # List of chans shown

	# An array of data chans embeded in PostScript but whose curves are not to be shown
	# and their colors skipped over by those curves which are shown.
	$str .= '/not_shown [ ';
	$str .= join q{ }, @{$self->{not_shown}} unless $self->{close_gap}; # 'Pthhht!'
	$str .= " ] def \n";

	# Y2 axis (re-)numbered for PostScript.
	$str .= '/y2 [';
	if ($self->{close_gap}) {
		$str .= join q{ }, gap_free_skip( $self->{y2}, $self->{not_shown} );
	}
	else {
		$str .= join q{ }, @{ $self->{y2} };
	}

	$str .= "] def \n";    # Y2 axis
	return $str;
}

# Given two arrays retrun a copy of 2nd array after decrementing its elements
# for each lesser element of 1st array. Used to provide PostScript with /column_arrays
# named 0 thru N with no gaps when chans have been skipped over to graph.
sub gap_free_skip {
	my ( $shown_aref, $not_shown_aref ) = @_; # Local, not part of $self->{foo} hash!
	my @gap_free = @$shown_aref;
	for my $i ( 0 .. $#gap_free ) {
		for my $j (@$not_shown_aref) {

			# Index decremented for each gap beneath it.
			if ( $j < $shown_aref->[$i] ) { --$gap_free[$i] }
		}
	}
	return @gap_free;
}

# Assign an arrow character from Symbol font to
# indicate which Y axis ought be read from.
sub y_arrow {
	ref( my $self = shift ) or croak 'Oops! Method y_arrow() is instance, not class.';
	my $i = shift;
	my $arrow = $EMPTY;
	my @y2 = @{$self->{y2}};
	if (@y2) {
		$arrow = '\254';
		for (@y2) { $arrow = '\256' if $_ == $i}
	}
	return $arrow;
}

# PostScript strings are ( ) delimited!
sub ps_str_esc {
	ref( my $self = shift ) or croak 'Oops! Method ps_str_esc() is instance, not class.';
	$_[0] =~ s/\(/\\(/gm;
	$_[0] =~ s/\)/\\)/gm;
	$self->verbose( "ps_str_esc(): $_[0] \n", 2);
	return $_[0];
}

# Build label for chans shown, list of those not to show.
sub chans_elect {
	ref( my $self = shift ) or croak 'Oops! Method chans_elect() is instance, not class.';

	for ( @{ $self->{names} } ) { $_ = $self->ps_str_esc($_) }

	my @ps_string_list = qw(
		label_top
		label_x
		label_x_2
		label_y1
		label_y1_2
		label_y2
		label_y2_2
	);

	for (@ps_string_list) { $self->{$_} = $self->ps_str_esc($self->{$_}) }

	# Collect list of shown-channel names
	# Prettify them into a graph legend good for B&W, not just color.
	for (@{ $self->{y1} }, @{ $self->{y2} }) {
		my $arrow = $self->y_arrow($_);
		$self->{label_x_proc} .= " ($arrow$_) $_ show_color_id ($self->{names}->[$_]  ) show ";
	}

	# Determine list of channels not to show.
	for ( 1 .. $#{$self->{names}} ) {

		# Mitigate an RE between Perl & PostScript by swaping all
		# escaped-for-PostScript string delimiters with Perl RE dots.
		my $re = $self->{names}->[$_];
		$re =~ tr/\\()/.../;

		push @{$self->{not_shown}}, $_ unless $self->{label_x_proc} =~ m/$re/m;

		# Problems may still exist between Perl RE's and PostScript syntax.
		# Diagnose these via CLI if in doubt by setting $verbosity = 2.
		$self->verbose(
			"RE Check 1: \n\t" . $self->{label_x_proc}
			. "\n\t =~ \n\t$re" . "\n"
			, 2
		);
		$self->verbose(
			'RE Check 2: not_shown = '
			. join(', ', @{$self->{not_shown}}) . "\n\n"
			, 2
		);
	}

	$self->{label_x_proc} = "/label_x_proc { $self->{label_x_proc} } def \n";
	$self->verbose( "LABEL X PROC: $self->{label_x_proc} \n", 2);
	return 'Pthhht! to Perl::Critic';
}

# Output data in PostScript file format.
sub write_eps {
	ref( my $self = shift ) or croak 'Oops! Method write_eps() is instance, not class.';
	$self->{ps_path} = qq|$_[0]|;
	local $OUTPUT_AUTOFLUSH = 1; # from 'use ENGLISH'

	my ( $ps_user_defs ) = $self->ps_defs_insert();

	if ( open my $fh, '>', "$self->{ps_path}" ) {

		# Embed filename sans path in PostScript header.
		$self->{ps_header} =~ s/%%Title:/%%Title: ($self->{ps_path})/m;

		# Embed document font resources.
		my $doc_rsrcs = "font Symbol $self->{font_name}";
		$self->{ps_header} =~ s/%%DocumentResources:/%%DocumentResources: $doc_rsrcs/m;

		# IMPORTANT NOTE: Know that Perl::Critic errs about the package vars
		# named like "$Chart::EPS_graph::PS::ps_foo" below. They are needed!

		print {$fh} $self->{ps_header};
		print {$fh} $Chart::EPS_graph::PS::ps_web_colors_dict;
		print {$fh} $Chart::EPS_graph::PS::ps_prolog_generic;
		print {$fh} $Chart::EPS_graph::PS::ps_prolog_graphing;
		print {$fh} $Chart::EPS_graph::PS::ps_prolog_data_arrays;
		print {$fh} $Chart::EPS_graph::PS::ps_prolog_drawing;