File Coverage

blib/lib/SQLite/More.pm

Criterion	Covered	Total	%
statement	174	200	87.0
branch	35	62	56.4
condition	22	39	56.4
subroutine	55	65	84.6
pod	1	14	7.1
total	287	380	75.5

package SQLite::More;
our $VERSION = '0.10';
use 5.008008;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw(nvl decode random min max sum avg geomavg stddev median percentile distance) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(sqlite_more);
use DBD::SQLite 1.27;  #minimum with $dbh->sqlite_create_function
use DBI         1.609; #minimum with $dbh->sqlite_create_function
use Digest::MD5;
use Carp;

sub sqlite_more
{
  my $dbh=shift();

  $dbh->sqlite_create_function( 'nvl',       2, sub { nvl(@_) } );
  $dbh->sqlite_create_function( 'decode',   -1, sub { decode(@_) } );
#  $dbh->sqlite_create_function( 'sysdate',   0, sub { sysdate() } ); #hm
  $dbh->sqlite_create_function( 'upper',     1, sub { uc($_[0]) } );
  $dbh->sqlite_create_function( 'lower',     1, sub { lc($_[0]) } );
  $dbh->sqlite_create_function( 'least',    -1, sub { min(@_) } );
  $dbh->sqlite_create_function( 'greatest', -1, sub { max(@_) } );
  $dbh->sqlite_create_function( 'md5',       1, sub { Digest::MD5::md5(@_) } );
  $dbh->sqlite_create_function( 'md5_hex',   1, sub { Digest::MD5::md5_hex(@_) } );
  $dbh->sqlite_create_function( 'random',    2, sub { random(@_) } );
  $dbh->sqlite_create_function( 'sprintf',  -1, sub { sprintf(shift(),@_) } );
  $dbh->sqlite_create_function( 'time',      0, sub { time() } );

  $dbh->sqlite_create_function( 'sqrt',      1, sub { sqrt(shift) } );
  $dbh->sqlite_create_function( 'power',     2, sub { shift() ** shift() } );
  $dbh->sqlite_create_function( 'ln',        1, sub { log(shift) } ); #2.71
  $dbh->sqlite_create_function( 'log',       1, sub { log(shift) } ); #2.71
  $dbh->sqlite_create_function( 'loge',      1, sub { log(shift) } ); #2.71
  $dbh->sqlite_create_function( 'log10',     1, sub { log(shift)/log(10) } );
  $dbh->sqlite_create_function( 'log2',      1, sub { log(shift)/log(2) } );
  $dbh->sqlite_create_function( 'pi',        0, sub { 3.14159265358979323846264338327950288419716939937510 } );
  $dbh->sqlite_create_function( 'sin',       1, sub { sin(shift) } );
  $dbh->sqlite_create_function( 'cos',       1, sub { cos(shift) } );
  $dbh->sqlite_create_function( 'tan',       1, sub { sin($_[0])/cos($_[0]) } );
  $dbh->sqlite_create_function( 'atan2',     2, sub { atan2(shift,shift) } );
  $dbh->sqlite_create_function( 'perlhash', -1, sub { perlhash(@_) } );

  $dbh->sqlite_create_function( 'distance',  4, sub { distance(@_) } );

 #$dbh->sqlite_create_function( 'sum',      -1, sub { sum(@_) } );
  $dbh->sqlite_create_aggregate( "variance", 1, 'SQLite::More::variance' );
  $dbh->sqlite_create_aggregate( "stddev",   1, 'SQLite::More::stddev' );
  $dbh->sqlite_create_aggregate( "median",   1, 'SQLite::More::median' );
  $dbh->sqlite_create_aggregate( "percentile", 2, 'SQLite::More::percentile' );

}

sub nvl  #copied from Acme::Tools 1.14
{
  return $_[0] if defined $_[0] and length($_[0]) or @_==1;
  return $_[1] if @_==2;
  return nvl(@_[1..$#_]) if @_>2;
  return undef;
}
sub decode  #copied from Acme::Tools 1.14
{
  croak "Must have a mimimum of two arguments" if @_<2;
  my $uttrykk=shift;
  if(defined$uttrykk){ shift eq $uttrykk and return shift or shift for 1..@_/2 }
  else               { not defined shift and return shift or shift for 1..@_/2 }
  return shift;
}
sub random  #copied from Acme::Tools 1.14
{
  my($from,$to)=@_;
  if(ref($from) eq 'ARRAY'){
      return $$from[random($#$from)];
  }
  ($from,$to)=(0,$from) if @_==1;
  ($from,$to)=($to,$from) if $from>$to;
  return int($from+rand(1+$to-$from));
}
sub min  #copied from Acme::Tools 1.14
{
  my $min;
  for(@_){ $min=$_ if defined($_) and !defined($min) || $_<$min }
  $min;
}
sub max  #copied from Acme::Tools 1.14
{
  my $max;
  for(@_){ $max=$_ if defined($_) and !defined($max) || $_>$max }
  $max;
}
sub sum  #copied from Acme::Tools 1.14
{
  my $sum; no warnings;
  $sum+=$_ for @_;
  $sum;
}
sub avg  #copied from Acme::Tools 1.14
{
  my $sum=0;
  no warnings;
  $sum+=$_ for @_;
  return $sum/@_ if @_>0;
  return undef;
}
sub geomavg   #copied from Acme::Tools 1.14
{ exp(avg(map log($_),@_)) }
sub stddev  #copied from Acme::Tools 1.14
{
  my $sumx2; $sumx2+=$_*$_ for @_;
  my $sumx; $sumx+=$_ for @_;
  sqrt( (@_*$sumx2-$sumx*$sumx)/(@_*(@_-1)) );
}
sub median  #copied from Acme::Tools 1.14
{
  no warnings;
  my @list = sort {$a<=>$b} @_;
  my $n=@list;
  $n%2
    ? $list[($n-1)/2]
    : ($list[$n/2-1] + $list[$n/2])/2;
}
sub percentile  #copied from Acme::Tools 1.14
{
  my(@p,@t,@ret);
  if(ref($_[0]) eq 'ARRAY'){ @p=@{shift()} }
  elsif(not ref($_[0]))    { @p=(shift())  }
  else{croak()}
  @t=@_;
  return if not @p;
  croak if not @t;
  @t=sort{$a<=>$b}@t;
  push@t,$t[0] if @t==1;
  for(@p){
    croak if $_<0 or $_>100;
    my $i=(@t+1)*$_/100-1;
    push@ret,
      $i<0       ? $t[0]+($t[1]-$t[0])*$i:
      $i>$#t     ? $t[-1]+($t[-1]-$t[-2])*($i-$#t):
      $i==int($i)? $t[$i]:
                   $t[$i]*(int($i+1)-$i) + $t[$i+1]*($i-int($i));
  }
  return @p==1 ? $ret[0] : @ret;
}
our $Distance_factor=3.141592653589793238462643383279502884197169399375105820974944592307816406286 / 180;
sub distance  #copied from Acme::Tools 1.14
{
  my($lat1,$lon1,$lat2,$lon2)=map $Distance_factor*$_, @_;
  my $a= sin(($lat2-$lat1)/2)**2
       + sin(($lon2-$lon1)/2)**2 * cos($lat1) * cos($lat2);
  my $sqrt_a  =sqrt($a);    $sqrt_a  =1 if $sqrt_a  >1;
  my $sqrt_1ma=sqrt(1-$a);  $sqrt_1ma=1 if $sqrt_1ma>1;
  my $c=2*atan2($sqrt_a,$sqrt_1ma);
  my($Re,$Rp)=( 6378137.0, 6356752.3 ); #earth equatorial and polar radius
  my $R=$Re-($Re-$Rp)*sin(abs($lat1+$lat2)/2); #approx
  return $c*$R;
}
sub perlhash
{
  my($hashname,$key,$val)=@_;
  $hashname=((caller(3))[0]||'main').'::'.$hashname if $hashname!~/::/;
  die if not $hashname=~/^(\w+::)*\w+$/; #noedv?
  no strict 'refs';
  my $r=$$hashname{$key};
  $$hashname{$key}=$val if @_>=3;
  return $r;
}


1;
package SQLite::More::variance;
  sub new {bless [],shift}sub step{push @{$_[0]},$_[1]}
  sub finalize {
      my $self = shift;
      my $n = @$self;
      return undef if not defined $n or $n < 2; #need at least 2
      my $avg = 0;
      $avg += $_ for @$self;
      $avg /= $n;
      my $sigma = 0;
      $sigma += ($_-$avg)**2 for @$self;
      $sigma /= $n - 1;
      return $sigma;
  }
1;

package SQLite::More::stddev;
  sub new {bless {n=>undef,sumx=>undef,sumx2=>undef},shift}
  sub step{
    my($self,$value)=@_;
    $$self{'n'}++;
    $$self{'sumx'}+=$value;
    $$self{'sumx2'}+=$value**2;
  }
  sub finalize {
    my $self=shift;
    my $n=$$self{'n'};
    return undef if not defined $n or $n < 2; #need at least 2
    return sqrt( ($n*$$self{'sumx2'}-$$self{'sumx'}**2)/$n/($n-1) );
  }
1;

package SQLite::More::median;
  sub new {bless [],shift}sub step{push @{$_[0]},$_[1]}
  sub finalize {SQLite::More::median(@{$_[0]})}
1;

package SQLite::More::percentile;
  sub new {bless [],shift}
  sub step{
    my($self,$percentile,$value)=@_;
    push @$self,$percentile if not @$self;
    die if $$self[0] != $percentile;
    push @$self,$value;
  }
  sub finalize {
    #$_[0][0]*=100 if $_[0][0]<2; #hm
    SQLite::More::percentile(@{$_[0]})
  }

package SQLite::More::correlation;
  sub new {bless [],shift}sub step{push @{$_[0]},$_[1]}
  sub finalize {
  }
1;

__END__