File Coverage

blib/lib/Tk/Chart/Utils.pm

Criterion	Covered	Total	%
statement	21	274	7.6
branch	0	78	0.0
condition	0	15	0.0
subroutine	7	35	20.0
pod	0	11	0.0
total	28	413	6.7

package Tk::Chart::Utils;

#=====================================================================================
# $Author    : Djibril Ousmanou                                                      $
# $Copyright : 2011                                                                  $
# $Update    : 21/10/2011 12:44:13                                                   $
# $AIM       : Private functions and public shared methods between Tk::Chart modules $
#=====================================================================================

use warnings;
use strict;
use Carp;

use vars qw($VERSION);
$VERSION = '1.04';

use Exporter;
use POSIX qw / floor /;

my @module_export = qw (
  _maxarray   _minarray   _isanumber _roundvalue
  zoom        zoomx      zoomy       clearchart
  _quantile   _moy       _nonoutlier _get_controlpoints
  enabled_automatic_redraw           disabled_automatic_redraw
  _delete_array_doublon redraw       add_data
  delete_balloon                     set_balloon
  _isainteger                        _set_data_cumulate_percent
);
my @modules_display = qw/ display_values /;

use base qw/ Exporter /;
our @EXPORT      = @module_export;
our @EXPORT_OK   = @modules_display;
our %EXPORT_TAGS = (
  DUMMIES => \@module_export,
  DISPLAY => \@modules_display,
);

my $EMPTY = q{};

sub _delete_array_doublon {
  my ($ref_tab) = @_;

  my %temp;
  return grep { !$temp{$_}++ } @{$ref_tab};
}

sub _maxarray {
  my ($ref_number) = @_;
  my $max;

  for my $chiffre ( @{$ref_number} ) {
    next if ( !_isanumber($chiffre) );
    $max = _max( $max, $chiffre );
  }

  return $max;
}

sub _minarray {
  my ($ref_number) = @_;
  my $min;

  for my $chiffre ( @{$ref_number} ) {
    next if ( !_isanumber($chiffre) );

    $min = _min( $min, $chiffre );
  }

  return $min;
}

sub _max {
  my ( $a, $b ) = @_;
  if ( not defined $a ) { return $b; }
  if ( not defined $b ) { return $a; }
  if ( not defined $a and not defined $b ) { return; }

  if   ( $a >= $b ) { return $a; }
  else              { return $b; }

  return;
}

sub _min {
  my ( $a, $b ) = @_;
  if ( not defined $a ) { return $b; }
  if ( not defined $b ) { return $a; }
  if ( not defined $a and not defined $b ) { return; }

  if   ( $a <= $b ) { return $a; }
  else              { return $b; }

  return;
}

sub _moy {
  my ($ref_values) = @_;

  my $total_values = scalar @{$ref_values};

  return if ( $total_values == 0 );

  my $moy = 0;
  for my $value ( @{$ref_values} ) {
    $moy += $value;
  }

  $moy = ( $moy / $total_values );

  return $moy;
}

sub _ispair {
  my ($number) = @_;

  if ( !_isainteger($number) ) {
    croak "$number not an integer\n";
  }

  if ( $number % 2 == 0 ) {
    return 1;
  }

  return;
}

sub _isainteger {
  my ($number) = @_;

  if ( ( defined $number ) and ( $number =~ m{^\d+$} ) ) {
    return 1;
  }

  return;
}

sub _median {
  my ($ref_values) = @_;

  # sort data
  my @values = sort { $a <=> $b } @{$ref_values};
  my $total_values = scalar @values;
  my $median;

  # Number of data pair
  if ( _ispair($total_values) ) {

    # 2 values for center
    my $value1 = $values[ $total_values / 2 ];
    my $value2 = $values[ ( $total_values - 2 ) / 2 ];
    $median = ( $value1 + $value2 ) / 2;
  }

  # Number of data impair
  else {
    $median = $values[ ( $total_values - 1 ) / 2 ];
  }

  return $median;
}

# The Quantile is calculated as the same excel algorithm and
# is equivalent to quantile type 7 in R quantile package.
sub _quantile {
  my ( $ref_data, $quantile_number ) = @_;

  my @values = sort { $a <=> $b } @{$ref_data};
  if ( not defined $quantile_number ) { $quantile_number = 1; }

  if ( $quantile_number == 0 ) { return $values[0]; }

  my $count = scalar @{$ref_data};

  if ( $quantile_number == 4 ) { return $values[ $count - 1 ]; }

  my $k_quantile = ( ( $quantile_number / 4 ) * ( $count - 1 ) + 1 );
  my $f_quantile = $k_quantile - POSIX::floor($k_quantile);
  $k_quantile = POSIX::floor($k_quantile);

  # interpolation
  my $ak_quantile     = $values[ $k_quantile - 1 ];
  my $akplus_quantile = $values[$k_quantile];

  # Calcul quantile
  my $quantile = $ak_quantile + ( $f_quantile * ( $akplus_quantile - $ak_quantile ) );

  return $quantile;
}

sub _nonoutlier {
  my ( $ref_values, $q1, $q3 ) = @_;

  # interquartile range,
  my $iqr = $q3 - $q1;

  # low and up boundaries
  my $low_boundary = $q1 - ( 1.5 * $iqr );
  my $up_boundary  = $q3 + ( 1.5 * $iqr );

  # largest non-outlier and smallest non-outlier
  my ( $l_nonoutlier, $s_nonoutlier );
  for my $value ( sort { $a <=> $b } @{$ref_values} ) {
    if ( $value > $low_boundary ) {
      $s_nonoutlier = $value;
      last;
    }
  }

  for my $value ( reverse sort { $a <=> $b } @{$ref_values} ) {
    if ( $value < $up_boundary ) {
      $l_nonoutlier = $value;
      last;
    }
  }

  return ( $s_nonoutlier, $l_nonoutlier );
}

sub _roundvalue {
  my ($value) = @_;
  if ( $value > 10000 ) {
    return sprintf '%.2e', $value;
  }
  return sprintf '%.5g', $value;
}

# Test if value is a real number
sub _isanumber {
  my ($value) = @_;

  if ( not defined $value ) {
    return;
  }
  if ( $value
    =~ /^(?:(?i)(?:[+-]?)(?:(?=[0123456789]|[.])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[E])(?:(?:[+-]?)(?:[0123456789]+))|))$/
    )
  {
    return 1;
  }

  return;
}

sub _get_controlpoints {
  my ( $cw, $ref_array ) = @_;

  my $nbrelt = scalar @{$ref_array};

  if ( $nbrelt <= 4 ) {
    return $ref_array;
  }

  # First element
  my @all_controlpoints = ( $ref_array->[0], $ref_array->[1] );

  for ( my $i = 0; $i <= $nbrelt; $i = $i + 2 ) {
    my @point_a = ( $ref_array->[$i], $ref_array->[ $i + 1 ] );
    my @point_b = ( $ref_array->[ $i + 2 ], $ref_array->[ $i + 3 ] );
    my @point_c = ( $ref_array->[ $i + 4 ], $ref_array->[ $i + 5 ] );

    last if ( !$ref_array->[ $i + 5 ] );

    # Equation between pointa and PointC
    # Coef = (yc -ya) / (xc -xa)
    # D1 : Y = Coef * X + (ya - (Coef * xa))
    my $coef = ( $point_c[1] - $point_a[1] ) / ( $point_c[0] - $point_a[0] );

    # Equation for D2 ligne paralelle to [AC] with PointB
    # D2 : Y = (Coef * X) + yb - (coef * xb)
    # The 2 control points
    my $d2line = sub {
      my ($x) = @_;

      my $y = ( $coef * $x ) + $point_b[1] - ( $coef * $point_b[0] );
      return $y;
    };

    # distance
    my $distance = 0.95;

    # xc1 = ( (xb - xa ) / 2 ) + xa
    # yc1 = via D2
    my @control_point1;
    $control_point1[0] = ( $distance * ( $point_b[0] - $point_a[0] ) ) + $point_a[0];
    $control_point1[1] = $d2line->( $control_point1[0] );
    push @all_controlpoints, ( $control_point1[0], $control_point1[1] );

    # points
    push @all_controlpoints, ( $point_b[0], $point_b[1] );

    # xc2 = ( (xc - xb ) / 2 ) + xb
    # yc2 = via D2
    my @control_point2;
    $control_point2[0] = ( ( 1 - $distance ) * ( $point_c[0] - $point_b[0] ) ) + $point_b[0];
    $control_point2[1] = $d2line->( $control_point2[0] );

    push @all_controlpoints, ( $control_point2[0], $control_point2[1] );
  }

  push @all_controlpoints, $ref_array->[ $nbrelt - 2 ], $ref_array->[ $nbrelt - 1 ];

  return \@all_controlpoints;
}

sub _set_data_cumulate_percent {
  my ( $cw, $ref_data ) = @_;

  # x-axis
  my @new_data = ( $ref_data->[0] );

  # Number of data and values in a data
  my $number_values = scalar @{ $ref_data->[0] };
  my $number_data   = scalar @{$ref_data} - 1;
  push @new_data, [] for ( 1 .. $number_data );

  # Change data to set percent data instead values
  for my $index_value ( 0 .. $number_values - 1 ) {
    my $sum = 0;

    # Sum calculate
    for my $index_data ( 1 .. $number_data ) {
      if ( $ref_data->[$index_data][$index_value] ) { $sum += $ref_data->[$index_data][$index_value]; }
    }

    # Change value
    for my $index_data ( 1 .. $number_data ) {
      next if ( ! $ref_data->[$index_data][$index_value] );
      my $new_value = ( $ref_data->[$index_data][$index_value] / $sum ) * 100;
      $new_data[$index_data][$index_value] = sprintf '%.5g', $new_value;
    }
  }

  return \@new_data;
}

sub redraw {
  my ($cw) = @_;

  $cw->_chartconstruction;
  return;
}

sub delete_balloon {
  my ($cw) = @_;

  $cw->{RefChart}->{Balloon}{State} = 0;
  $cw->_balloon();

  return;
}

sub add_data {
  my ( $cw, $ref_data, $legend ) = @_;

  # Doesn't work for Pie graph
  if ( $cw->class eq 'Pie' ) {
    $cw->_error("This method 'add_data' not allowed for Tk::Chart::Pie\n");
    return;
  }

  my $refdata = $cw->{RefChart}->{Data}{RefAllData};

  # Cumulate pourcent => data change
  my $cumulatepercent = $cw->cget( -cumulatepercent );
  if ( defined $cumulatepercent and $cumulatepercent == 1 ) {
    $refdata = $cw->{RefChart}->{Data}{RefAllDataBeforePercent};
  }

  push @{$refdata}, $ref_data;
  if ( $cw->{RefChart}->{Legend}{NbrLegend} > 0 ) {
    push @{ $cw->{RefChart}->{Legend}{DataLegend} }, $legend;
  }

  $cw->plot($refdata);

  return;
}

sub set_balloon {
  my ( $cw, %options ) = @_;

  $cw->{RefChart}->{Balloon}{State} = 1;

  if ( defined $options{-colordatamouse} ) {
    if ( scalar @{ $options{-colordatamouse} } < 2 ) {
      $cw->_error(
        "Can't set -colordatamouse, you have to set 2 colors\nEx : -colordatamouse => ['red','green'],", 1 );
    }
    else {
      $cw->{RefChart}->{Balloon}{ColorData} = $options{-colordatamouse};
    }
  }
  if ( defined $options{-morepixelselected} ) {
    $cw->{RefChart}->{Balloon}{MorePixelSelected} = $options{-morepixelselected};
  }
  if ( defined $options{-background} ) {
    $cw->{RefChart}->{Balloon}{Background} = $options{-background};
  }

  $cw->_balloon();

  return;
}

sub zoom {
  my ( $cw, $zoom ) = @_;

  my ( $new_width, $new_height ) = $cw->_zoomcalcul( $zoom, $zoom );
  $cw->configure( -width => $new_width, -height => $new_height );
  $cw->toplevel->geometry($EMPTY);

  return 1;
}

sub zoomx {
  my ( $cw, $zoom ) = @_;

  my ( $new_width, $new_height ) = $cw->_zoomcalcul( $zoom, undef );
  $cw->configure( -width => $new_width );
  $cw->toplevel->geometry($EMPTY);

  return 1;
}

sub zoomy {
  my ( $cw, $zoom ) = @_;

  my ( $new_width, $new_height ) = $cw->_zoomcalcul( undef, $zoom );
  $cw->configure( -height => $new_height );
  $cw->toplevel->geometry($EMPTY);

  return 1;
}

# Clear the Canvas Widget
sub clearchart {
  my ($cw) = @_;

  $cw->update;
  $cw->delete( $cw->{RefChart}->{TAGS}{AllTagsChart} );

  return;
}

sub display_values {
  my ( $cw, $ref_data, %options ) = @_;

  # Doesn't work for Pie graph
  if ( $cw->class eq 'Pie' ) {
    $cw->_error("This method 'display_values' not allowed for Tk::Chart::Pie\n");
    return;
  }
  elsif ( $cw->class eq 'Bars' ) {
    $cw->_error("This method 'display_values' not allowed for Tk::Chart::Bars\n");
    return;
  }

  if ( !( defined $ref_data and ref $ref_data eq 'ARRAY' ) ) {
    $cw->_error( 'data not defined', 1 );
    return;
  }
  $cw->{RefChart}->{Data}{RefDataToDisplay}       = $ref_data;
  $cw->{RefChart}->{Data}{RefOptionDataToDisplay} = \%options;

  if ( $cw->class eq 'Areas' ) {
    foreach my $ref_value ( @{$ref_data} ) {
      unshift @{$ref_value}, undef;
    }
  }

  if ( defined $cw->{RefChart}->{Data}{PlotDefined} ) {
    $cw->redraw;
  }

  return;
}

sub enabled_automatic_redraw {
  my ($cw) = @_;

  my $class = $cw->class;
  foreach my $key (qw{ Down End Home Left Next Prior Right Up }) {
    $cw->Tk::bind( "Tk::Chart::$class", "",         undef );
    $cw->Tk::bind( "Tk::Chart::$class", "", undef );
  }

  # recreate graph after widget resize
  $cw->Tk::bind( '' => sub { $cw->_chartconstruction; } );
  return;
}

sub disabled_automatic_redraw {
  my ($cw) = @_;

  my $class = $cw->class;
  foreach my $key (qw{ Down End Home Left Next Prior Right Up }) {
    $cw->Tk::bind( "Tk::Chart::$class", "",         undef );
    $cw->Tk::bind( "Tk::Chart::$class", "", undef );
  }

  # recreate graph after widget resize
  $cw->Tk::bind( '' => undef );
  return;
}

1;

__END__