File Coverage

blib/lib/URI/GoogleChart.pm

Criterion	Covered	Total	%
statement	175	182	96.1
branch	96	116	82.7
condition	51	73	69.8
subroutine	20	20	100.0
pod	1	2	50.0
total	343	393	87.2

package URI::GoogleChart;

use strict;

our $VERSION = "1.02";

use URI;
use Carp qw(croak carp);

my $BASE = "http://chart.apis.google.com/chart";

our %TYPE_ALIAS = (
    "lines" => "lc",
    "sparklines" => "ls",
    "xy-lines" => "lxy",

    "horizontal-stacked-bars" => "bhs",
    "vertical-stacked-bars" => "bvs",
    "horizontal-grouped-bars" => "bhg",
    "vertical-grouped-bars" => "bvg",

    "pie" => "p",
    "pie-3d" => "p3",
    "3d-pie" => "p3",
    "concentric-pie" => "pc",

    "venn" => "v",
    "scatter-plot" => "s",
    "radar" => "r",
    "radar-splines" => "rs",
    "google-o-meter" => "gom",

    "africa" => "t",
    "asia" => "t",
    "europe" => "t",
    "middle_east" => "t",
    "south_america" => "t",
    "usa" => "t",
    "world" => "t",
);

our %COLOR_ALIAS = (
    "red"     => "FF0000",
    "lime"    => "00FF00",
    "blue"    => "0000FF",

    "green"   => "008000",
    "navy"    => "000080",

    "yellow"  => "FFFF00",
    "aqua"    => "00FFFF",
    "fuchsia" => "FF00FF",
    "maroon"  => "800000",
    "purple"  => "800080",
    "olive"   => "808000",
    "teal"    => "008080",

    "white"   => "FFFFFF",
    "silver"  => "C0C0C0",
    "gray"    => "808080",
    "black"   => "000000",

    "transparent" => "00000000",
);

our %AXIS_ALIAS = (
    "left"   => "y",
    "right"  => "r",
    "top"    => "t",
    "bottom" => "x",
);

our %ENCODING_ALIAS = (
    "text"     => "t",
    "simple"   => "s",
    "extended" => "e",
);

# constants for data encoding
my @C = ("A" .. "Z", "a" .. "z", 0 .. 9, "-", ".");
my $STR_s = join("", @C[0 .. 61]);
my $STR_e = do {
    my @v;
    for my $x (@C) {
	for my $y (@C) {
	    push(@v, "$x$y");
	}
    }
    join("", @v);
};
die unless length($STR_s) == 62;
die unless length($STR_e) == 4096 * 2;


sub new {
    my($class, $type, $width, $height, %opt) = @_;

    croak("Chart type not provided") unless $type;
    croak("Chart size not provided") unless $width && $height;

    my %param = (
	cht => $TYPE_ALIAS{$type} || $type,
	chs => join("x", $width, $height),
    );
    $param{chtm} = $type if $param{cht} eq "t" && $type ne "t";  # maps

    my %handle = (
	data => \&_data,
	range => 1,
	min => 1,
	max => 1,
	range_round => 1,
	range_show => 1,
	encoding => 1,

	color => sub {
	    my $v = shift;
	    $v = [$v] unless ref($v);
	    $param{chco} = join(",", map _color($_), @$v);
	},
	background => sub {
	    $param{chf} = "bg,s," . _color(shift);
	},
	title => sub {
	    my $title = shift;
	    ($title, my($color, $size)) = @$title if ref($title) eq "ARRAY";
	    $title =~ s/\n+\z//;
	    $title =~ s/\n/|/g;
	    $param{chtt} = $title;
	    if (defined($color) || defined($size)) {
		$color = defined($color) ? _color($color) : "";
		$size = "" unless defined $size;
		$param{chts} = "$color,$size";
	    }
	},
	label => sub {
	    my $lab = shift;
	    $lab = [$lab] unless ref($lab) eq "ARRAY";
	    my $k = $param{cht} =~ /^p|^gom$/ ? "chl" : "chdl";
	    $param{$k} = join("|", @$lab);
	},
	rotate => sub {
	    my $p = shift;
	    $p += 360 while $p < 0;
	    $p /= 180 / 3.1416;  # convert to radians
	    $param{chp} = sprintf "%.2f", $p;
	},
	margin => sub {
	    my $m = shift;
	    $m = [($m) x 4] unless ref($m);
	    $param{chma} = join(",", @$m);
	}
    );

    my $data = delete $opt{data};  # need to be processed last
    for my $k (keys %opt) {
	if (my $h = $handle{$k}) {
	    $h->($opt{$k}, \%param, \%opt) if ref($h) eq "CODE";
	}
	else {
	    $param{$k} = $opt{$k};
	    carp("Unrecognized parameter '$k' embedded in GoogleChart URI")
		unless $k =~ /^ch/;
	}
    }
    _data($data, \%param, \%opt) if $data;

    # generate URI
    my $uri = URI->new($BASE);
    $uri->query_form(map { $_ => $param{$_} } _sort_chart_keys(keys %param));
    for ($uri->query) {
	s/%3A/:/g;
	s/%2C/,/g;
	s/%7C/|/g; # XXX doesn't work (it ends up encoded anyways)
	$uri->query($_);
    }
    return $uri;
}

sub _color {
    local $_ = shift;
    return $COLOR_ALIAS{$_} ||
	(/^[\da-fA-F]{3}\z/ ? join("", map "$_$_", split(//, $_)) : $_);
}

sub _sort_chart_keys {
    my %o = ( cht => 1, chtm => 2, chs => 3, chd => 100 );
    return sort { ($o{$a}||=99) <=> ($o{$b}||=99) || $a cmp $b } @_;
}

sub _default_minmax {
    my $param = shift;
    my $t = $param->{cht};
    return 0, undef if $t =~ /^p/;  # pie chart
    return 0, undef if $t eq "v";   # venn
    return 0, undef if $t =~ /^r/;  # radar chart
    return 0, undef if $t =~ /^b/;  # bar chart
    return 0, 100   if $t eq "gom"; # meter
    return;
}

sub _data {
    my($data, $param, $opt) = @_;

    # various shortcuts
    $data = _deep_copy($data);  # want to modify it
    if (ref($data) eq "ARRAY") {
	$data = [$data] unless ref($data->[0]);
    }
    elsif (ref($data) eq "HASH") {
	$data = [$data];
    }
    else {
	$data = [[$data]];
    }

    my $range = _deep_copy($opt->{range});
    for (qw(min max range_round range_show)) {
	(my $r = $_) =~ s/^range_//;
	$range->{""}{$r} = $opt->{$_} if exists $opt->{$_};
    }

    my $vcount = 0;
    for my $set (@$data) {
	$set = { v => $set } if ref($set) eq "ARRAY";
	my $v = $set->{v};
	my $r = $set->{range} ||= "";
	my $rh = $range->{$r} ||= {};

	my($min, $max) = _default_minmax($param);
	my $i = 0;
	for (@$v) {
	    next unless defined;
	    $min = $_ if !defined($min) || $_ < $min;
	    $max = $_ if !defined($max) || $_ > $max;
	    if ($param->{cht} =~ /^b.s\z/) {
		# stacked stuff
		$rh->{stacked}{min}[$i] ||= 0;
		$rh->{stacked}{max}[$i] ||= 0;
		$rh->{stacked}{$_ < 0 ? "min" : "max"}[$i] += $_;
	    }
	}
	continue {
	    $i++;
	}
	$vcount += @$v;

	if ($rh->{stacked}) {
	    # XXX we really only need to this after we have processed
	    # the last dataset, the other rounds it's wasted effort
	    ($min, $max) = (0, 0);
	    for (qw(min max)) {
		for my $v (@{$rh->{stacked}{$_}}) {
		    next unless defined $v;
		    if ($_ eq "min") {
			$min = $v if $v < $min;
		    }
		    else {
			$max = $v if $v > $max;
		    }
		}
	    }
	}

	if (defined $min) {
	    my %h = (min => $min, max => $max);
	    for my $k (keys %h) {
		if (defined $set->{$k}) {
		    $h{$k} = $set->{$k};
		}
		else {
		    $set->{$k} = $h{$k};
		}

		my $rv = $rh->{$k};
		if (!defined($rv) ||
		    ($k eq "min" && $h{$k} < $rv) ||
		    ($k eq "max" && $h{$k} > $rv)
		   )
		{
		    $rh->{$k} = $h{$k};
		}
	    }
	}
    }

    # should we round any of the ranges
    for my $r (values %$range) {
	next unless $r->{round};

	use POSIX qw(floor ceil);
	sub log10 { log(shift) / log(10) }

	my($min, $max) = @$r{"min", "max"};
	my $range = $max - $min;
	next if $range == 0;
	die "Assert" if $range < 0;

	my $step = 10 ** int(log10($range));
	$step /= 10 if $step / $range >= 0.1;
	$step *= 5 if $step / $range < 0.05;

	$min = floor($min / $step - 0.2) * $step;
	$max = ceil($max / $step + 0.2) * $step;

	# zero based minimum is usually a good thing so make it more likely
	$min = 0 if $min > 0 && $min/$range < 0.4;

	@$r{"min", "max"} = ($min, $max);
    }

    #use Data::Dump; dd $data;
    #use Data::Dump; dd $range;

    # encode data
    my $e = $ENCODING_ALIAS{$opt->{encoding} || ""} || $opt->{encoding};
    unless ($e) {
	# try to me a little smart about selecting a suitable encoding based
	# on the number of data points we're plotting and the resolution of
	# the generated image
	my @s = ($param->{chs} =~ /(\d+)/g);
	my $res = $s[0] * $s[1];
	if ($vcount < 20) {
	    $e = "t";
	}
	elsif ($vcount > 256 || $res < 300*200) {
	    $e = "s";
	}
	else {
	    $e = "e";
	}
    }

    my %enc = (
	t => {
	    null => -1,
	    sep1 => ",",
	    sep2 => "|",
	    fmt => sub {
		my $v = 100 * shift;
		$v = sprintf "%.1f", $v if $v ne int($v);
		$v;
	    },
	},
	s => {
	    null => "_",
	    sep1 => "",
	    sep2 => ",",
	    fmt => sub {
		return substr($STR_s, $_[0] * length($STR_s) - 0.5, 1);
	    },
	},
	e => {
	    null => "__",
	    sep1 => "",
	    sep2 => ",",
	    fmt => sub {
		return substr($STR_e, int($_[0] * length($STR_e) / 2 - 0.5) * 2, 2);
	    },
	}
    );
    my $enc = $enc{$e} || croak("unsupported encoding $e");
    my @res;
    for my $set (@$data) {
        my($min, $max) = @{$range->{$set->{range}}}{"min", "max"};
	my $v = $set->{v};
	for (@$v) {
	    if (defined($_) && $_ >= $min && $_ <= $max && $min != $max) {
		$_ = $enc->{fmt}(($_ - $min) / ($max - $min));
	    }
	    else {
		$_ = $enc->{null};
	    }
	}
	push(@res, join($enc->{sep1}, @$v));
    }
    $param->{chd} = "$e:" . join($enc->{sep2}, @res);

    # handle bar chart zero line if we charted negative data
    if ($param->{cht} =~ /^b/) {
        my($min, $max) = @{$range->{""}}{"min", "max"};
	if ($min < 0) {
	    $param->{chp} = $max < 0 ? 1 : sprintf "%.2f", -$min / ($max - $min);
	}
    }

    # enable axis labels?
    for (sort keys %$range) {
	my $r = $range->{$_};
	my @chxt = split(/,/, $param->{chxt} || "");
	my @chxr = split(/\|/, $param->{chxr} || "");
	if (my $rshow = $r->{show}) {
	    my($min, $max) = @$r{"min", "max"};
	    for ($min, $max) {
		$_ = sprintf "%.2g", $_;
	    }
	    push(@chxt, $AXIS_ALIAS{$rshow} || $rshow);
	    my $i = $#chxt;
	    push(@chxr, "$i,$min,$max");
	}
	if (@chxt) {
	    $param->{chxt} = join(",", @chxt);
	    $param->{chxr} = join("|", @chxr);
	}
    }
}

sub _deep_copy {
    my $o = shift;
    return $o unless ref($o);
    return [map _deep_copy($_), @$o] if ref($o) eq "ARRAY";
    return {map { $_ => _deep_copy($o->{$_}) } keys %$o} if ref($o) eq "HASH";
    die "Can't copy " . ref($o);
}

1;

__END__