Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??

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

In reply to Re: Bag uniform distribution algorithms by hdb
in thread Bag uniform distribution algorithms by davido

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others contemplating the Monastery: (11)
    As of 2014-08-29 12:44 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The best computer themed movie is:











      Results (280 votes), past polls