Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
 
PerlMonks  

Re: Bag uniform distribution algorithms

by hdb (Prior)
on Apr 26, 2013 at 09:16 UTC ( #1030796=note: print w/ replies, xml ) Need Help??


in reply to Bag uniform distribution algorithms

Evaluation is key for this question. In addition to kennethk's score function I think the cumulative variance of positions is an appropriate measure. For the variance, a large value is good.

use strict; use warnings; use Math::Round; use Statistics::Basic qw(:all); use List::Util 'sum'; sub dispersion { my %p; my $pos = 0; push @{$p{$_}}, $pos++ while $_ = shift; my $var = 0; $var += variance( $p{$_} ) for ( keys %p ); return $var; } sub measure { my @series = @_; my %count; $count{$_}++ for @series; my $norm = sum values %count; $_ /= $norm for values %count; my %score = %count; my $metric = 0; for my $elem (@series) { $score{$elem} -= 1; for (keys %score) { $metric += $score{$_}**2; $score{$_} += $count{$_}; } } return $metric/@series; }
sub mix { my $bag = shift; my @str = sort { $bag->{$a} <=> $bag->{$b} } keys %$bag; my $list = ""; while( @str ) { my $tbi = shift @str; my $count = $bag->{$tbi}; $tbi .= shift @str while( @str and $bag->{$str[0]} +== $count ); my $l = length $list; if( !$l ) { $list = $tbi x $count; } else { for my $pos ( reverse 0..$count-1 ) { substr( $list, round($pos / ($count-1) + * $l), 0 ) = $tbi ; } } } my @series = split '', $list; return \@series; } sub gen { # kennethk my $href = shift; my %score = %$href; my $norm = sum values %score; my @series; for (1 .. $norm) { my ($max, $elem) = 0; for (keys %score) { ($max, $elem) = ($score{$_}, $_) if $score{$_} >= $max; $score{$_} += $href->{$_}; } push @series, $elem; $score{$elem} -= $norm; } return \@series; } sub genUK { # BrowserUK my $href = shift; my @kByV = sort{ $href->{ $b } <=> $href->{ $a } } keys %$href; my @dist = ( $kByV[0] ) x $href->{ $kByV[0] }; shift @kByV; while( @kByV ) { my $k = shift @kByV; my $v = $href->{ $k }; my $n = int( @dist / ( $v+1 ) ); my $p = $n * $v; splice( @dist, $p, 0, $k ), $p -= $n for reverse 1 .. $v; } return \@dist; } sub kcott { my $bagref = shift; my %bag = %$bagref; my @distribution; for my $key (sort { $bag{$b} <=> $bag{$a} } keys %bag) { my $base_offset = int(@distribution / ($bag{$key} + 1) + 0.5); + my $offset = $base_offset; for (1 .. $bag{$key}) { next unless $_ % 2; splice @distribution, $offset, 0, $key; if ($_ < $bag{$key}) { splice @distribution, -$offset, 0, $key; } $offset += $base_offset + 1; } } return \@distribution; }
sub evaluate { my $cand = shift; my $bags = shift; printf "\n%20s %15s %15s %s\n", "Monk", "Better:higher", "Bett +er:lower", "Result"; print "------------------------------------------------------- +-----\n\n"; for my $bag (@$bags) { print "bag: "; print join ", ", map { +"$_ => ".$bag->{$_} } sort key +s %$bag ; print "\n\n"; for my $monk ( sort keys %$cand ) { my $result = $cand->{$monk}->($bag); my $disp = dispersion( @$result ); my $score = measure( @$result ); printf "%20s %15.2f %15.2f %s\n", $monk, $disp +, $score, join "", @$result; } print "\n"; } } my $bags = [ { A => 4, B => 2, C => 3, D => 1, }, { A => 4, B => 2, C => 3, D => 1, F => 2, G => 4, H=> 2, I=>30 + }, { A => 10, B=> 10, C => 10, }, ]; my $candidates = { # sub expects hash ref and returns array ref kennethk => \&gen, BrowserUK => \&genUK, kcott => \&kcott, hdb => \&mix, }; evaluate( $candidates, $bags );

which gives the following output

Monk Better:higher Better:lower Result ------------------------------------------------------------ bag: A => 4, B => 2, C => 3, D => 1 BrowserUK 24.41 0.45 ACBADCBACA hdb 25.72 0.37 ACBADCABCA kcott 25.72 0.37 ACBACDABCA kennethk 25.72 0.37 ACBADCABCA bag: A => 4, B => 2, C => 3, D => 1, F => 2, G => 4, H => 2, I => 30 BrowserUK 866.39 2.67 IIIIIIGAICIIIFBHI +GIAIICDIIGIIAFBHIIICGIIIAIIIIII hdb 1178.43 0.94 IAIIGIICIFIIBIAII +GIIHIDIICIFIIAIIGIBIIHICIIAIIGI kcott 893.56 2.31 IIIIIIAGIICIIIBHF +IAGIIIIDCIIGAIFHBIIICIIGAIIIIII kennethk 1283.68 0.78 IIGIAICIIHIIBIFII +GIAIIDIICIIGIAIIHIIBIFIICIGIAII bag: A => 10, B => 10, C => 10 BrowserUK 74.25 22.44 CBCBCBCBCBCBCBCBC +BCBAAAAAAAAAA hdb 222.75 0.44 ACBACBACBACBACBAC +BACBACBACBACB kcott 224.75 0.44 ABCABCABCABCABCCB +ACBACBACBACBA kennethk 222.75 0.44 CBACBACBACBACBACB +ACBACBACBACBA


Comment on Re: Bag uniform distribution algorithms
Select or Download Code

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://1030796]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (12)
As of 2015-07-07 19:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (93 votes), past polls