view release on metacpan or  search on metacpan

lib/Chart/GGPlot/Util/Scales.pm  view on Meta::CPAN

package Chart::GGPlot::Util::Scales;

# ABSTRACT: R 'scales' package functions used by Chart::GGPlot

# TODO: make a separate library, e.g. Color::Scales for the color palettes.
#  Some of the color palette function's signature may change.

use Chart::GGPlot::Setup qw(:base :pdl);

our $VERSION = '0.002003'; # VERSION

use Color::Brewer;
use Color::Library;
use Convert::Color::LCh;
use Data::Munge qw(elem);
use Machine::Epsilon qw(machine_epsilon);
use Math::Round qw(round);
use Memoize;
use PDL::Primitive qw(which interpol);
use PDL::Graphics::ColorSpace 0.203 qw(rgb_to_lab lab_to_rgb);
use Number::Format 1.75;
use Scalar::Util qw(looks_like_number);
use Time::Moment;
use Types::Standard qw(Int);

use POSIX qw(ceil floor log10);

use Role::Tiny ();

use Type::Params;
use Types::PDL qw(Piddle Piddle1D PiddleFromAny);
use Types::Standard qw(ArrayRef ConsumerOf Num Optional Str Maybe);

use Chart::GGPlot::Types qw(:all);
use Chart::GGPlot::Util::_Base qw(:all);
use Chart::GGPlot::Util::_Labeling qw(:all);
use Chart::GGPlot::Util::Scales::_Viridis;

use parent qw(Exporter::Tiny);

our @EXPORT_OK = qw(
  censor discard expand_range zero_range
  rescale squish
  hue_pal brewer_pal gradient_n_pal rescale_pal viridis_pal
  seq_gradient_pal div_gradient_pal
  area_pal
  identity_pal
  extended_breaks regular_minor_breaks log_breaks
  pretty pretty_breaks
  number comma percent dollar
  rgb255_to_csshex rgb_to_csshex
  csshex_to_rgb255
  colorname_to_csshex
);
our %EXPORT_TAGS = ( all => \@EXPORT_OK );


fun censor ( $p, $range = pdl([ 0, 1 ]), $only_finite = true ) {
    my ( $min, $max ) = $range->minmax;
    my $finite = $only_finite ? $p->isfinite : PDL->ones( $p->length );
    return $p->setbadif( $finite & ( ( $p < $min ) | ( $p > $max ) ) );
}


fun discard ( $p, $range = pdl([ 0, 1 ]) ) {
    my ( $min, $max ) = $range->minmax;
    return $p->where( ( ( $p >= $min ) & ( $p <= $max ) ) );
}

# Expand a range with a multiplicative or additive constant
fun expand_range ( $range, $mul = 0, $add = 0, $zero_width = 1 ) {
    state $check =
      Type::Params::compile( Piddle->plus_coercions(PiddleFromAny) );
    ($range) = $check->($range);

    return if ( $range->isempty );  # TODO: return undef or return empty $range?

    my ( $min, $max ) = $range->minmax;
    if ( zero_range($range) ) {
        return pdl( [ $max - $zero_width / 2, $min + $zero_width / 2 ] );
    }
    else {
        my $delta = ( $max - $min ) * $mul + $add;
        return pdl( [ $min - $delta, $max + $delta ] );
    }
}


fun zero_range ( $range, $tol = 1000 * machine_epsilon() ) {
    state $check =
      Type::Params::compile( Piddle1D->where( sub { $_->length == 2 } ) );
    ($range) = $check->($range);
    return ( abs( $range->at(1) - $range->at(0) ) < $tol );
}


fun squish ( $p, $range = pdl([ 0, 1 ]), $only_finite = true ) {
    my ( $min, $max ) = $range->minmax;
    my $finite = $only_finite ? $p->isfinite : PDL->ones( $p->length );
    my $r = $p->copy;

    $r->where( ( $finite & ( $r < $min ) ) ) .= $min;
    $r->where( ( $finite & ( $r > $max ) ) ) .= $max;
    return $r;
}

## scale

# Rescale range to have specified minimum and maximum
fun rescale ( $p, $to = pdl([0, 1]), $from = range_($p) ) {

lib/Chart/GGPlot/Util/Scales.pm  view on Meta::CPAN

}


fun pretty_breaks($n=5, %rest) {
    return sub {
        my ($x) = @_;

        my $f = $x->$_DOES('PDL::DateTime') ? 'pretty_dt' : 'pretty';
        no strict 'refs';
        return $f->($x, n=>$n, %rest);
    };
}

fun dollar ($p, :$accuracy=undef, :$scale=1, 
            :$prefix='$', :$suffix='',
            :$big_mark=',', :$decimal_mark='.',
            :$largest_with_cents=1e5, :$negative_parens=false) {
    return PDL::SV->new( [] ) if ( $p->length == 0 );

    $accuracy //= _need_cents( $p * $scale, $largest_with_cents ) ? 0.01 : 1;
    my $precision = List::AllUtils::max( -floor( log10($accuracy) ), 0 );
    my $negative  = ( $p->isgood & ( $p < 0 ) );

    my $fmt = Number::Format->new(
        -thousands_sep     => $big_mark,
        -mon_thousands_sep => $big_mark,
        -decimal_point     => $decimal_mark,
        -mon_decimal_point => $decimal_mark,
        -int_curr_symbol   => $prefix,
        ( $negative_parens ? ( -n_sign_posn => 0 ) : () ),

        # Number::Format would use locale's settings like P/N_SEP_BY_SPACE.
        # Here we force these values to align with R's scale::dollar to make
        # the behavior simple.
        -p_sep_by_space => 0,
        -n_sep_by_space => 0,
        -p_cs_precedes  => 1,
        -n_cs_precedes  => 1,
    );

    no warnings 'numeric';
    my @amount = map { $fmt->format_price( $_, $precision ); } @{ $p->unpdl };

    my $rslt = PDL::SV->new( \@amount );
    $rslt = $rslt->setbadif( $p->isbad ) if $p->badflag;
    return $rslt;
}

fun _need_cents ($p, $threshold) {
    return false if ($p->badflag and $p->isbad->all);
    return false if ($p->abs->max > $threshold);
    return !(
        (
            $p->badflag
            ? ( ( $p->floor == $p ) | $p->isbad )
            : ( $p->floor == $p )
        )->all
    );
}

fun percent ($p, :$accuracy=undef, :$scale=100,
             :$prefix='', :$suffix="%",
             :$big_mark=',', :$decimal_mark='.'
        ) {
    return number(
        $p,
        accuracy => $accuracy,
        scale    => $scale,
        prefix   => $prefix,
        suffix   => $suffix
    );
}

fun comma ($p, :$big_mark=',', %rest) {
    return number($p, big_mark => $big_mark, %rest);
}

fun number ($p, :$accuracy=1, :$scale=1,
            :$big_mark=' ', :$decimal_mark='.',
            :$prefix='', :$suffix=''
        ) {
    return PDL::SV->new( [] ) if $p->length == 0;

    $accuracy //= _accuracy($p);
    my $precision =
      List::AllUtils::max( -floor( log10( $accuracy / $scale ) ), 0 );
    my $fmt = Number::Format->new(
        -thousands_sep => $big_mark,
        -decimal_point => $decimal_mark
    );

    my @s = ( $p * $scale )->list;
    no warnings 'numeric';
    @s = map { "${prefix}${_}${suffix}" }
      map { $_ eq 'BAD' ? $_ : $fmt->format_number( $_, $precision ); } @s;

    my $rslt = PDL::SV->new( \@s );
    $rslt->setbadif( $p->isbad ) if $p->badflag;
    return $rslt;
}

fun _accuracy ($p) {
    return 1 if ((!$p->isfinite)->all);

    my $rng = range_($p, true, true);
    my $span = zero_range($rng) ? $rng->at(0)->abs : $rng->at(1) - $rng->at(0);
    return 1 if ($span == 0);
    return 10 ** (pdl($span)->log10->floor);  
}


sub rgb255_to_csshex { sprintf("#%02x%02x%02x", @_); }

sub rgb_to_csshex {
    rgb255_to_csshex(
        map { List::Util::max( 0, List::Util::min( 255, int( $_ * 256.0 ) ) ) }
          @_ );
}

sub csshex_to_rgb255 {
    my ($csshex) = @_;