gistfile1.PL

#!/usr/bin/env perl 
#===============================================================================
#
#         FILE:  recommendations.pl
#
#        USAGE:  ./recommendations.pl
#
#  DESCRIPTION:
#
#      OPTIONS:  ---
# REQUIREMENTS:  ---
#         BUGS:  ---
#        NOTES:  ---
#       AUTHOR:  Yongbin Yu (yyb), [email protected]
#      COMPANY:
#      VERSION:  1.0
#      CREATED:  2010년 03월 25일 01시 05분 58초
#     REVISION:  ---
#===============================================================================

use utf8;
use 5.010;

use strict;
use warnings;
use Data::Dumper;
use List::Util qw(sum);

my $critics = {
    'Lisa Rose' => {
        'Lady in the Water'  => 2.5,
        'Snake on a Plane'   => 3.5,
        'Just My Luck'       => 3.0,
        'Superman Returns'   => 3.5,
        'You, Me and Dupree' => 2.5,
        'The Night Listener' => 3.0
    },
    'Gene Seymour' => {
        'Lady in the Water'  => 3.0,
        'Snake on a Plane'   => 3.5,
        'Just My Luck'       => 1.5,
        'Superman Returns'   => 5.0,
        'You, Me and Dupree' => 3.0,
        'The Night Listener' => 3.5,
    },
    'Michael Phillips' => {
        'Lady in the Water'  => 2.5,
        'Snake on a Plane'   => 3.0,
        'Superman Returns'   => 3.5,
        'The Night Listener' => 4.0
    },
    'Claudia Puig' => {
        'Snake on a Plane'   => 3.5,
        'Just My Luck'       => 3.0,
        'Superman Returns'   => 4.0,
        'The Night Listener' => 4.5,
    },
    'Mick LaSalle' => {
        'Lady in the Water'  => 3.0,
        'Snake on a Plane'   => 4.0,
        'Just My Luck'       => 2.0,
        'Superman Returns'   => 3.0,
        'The Night Listener' => 3.0,
        'You, Me and Dupree' => 2.0,
    },
    'Jack atthews' => {
        'Lady in the Water'  => 3.0,
        'Snake on a Plane'   => 4.0,
        'The Night Listener' => 3.0,
        'Superman Returns'   => 5.0,
        'You, Me and Dupree' => 3.5,
    },
    'Toby' => {
        'Snake on a Plane'   => 4.5,
        'You, Me and Dupree' => 1.0,
        'Superman Returns'   => 4.0,
    },
};

sub sim_distance {
    my ( $prefs, $person1, $person2 ) = @_;
    my $common;

    map { $common->{$_} = 1 }
      grep { exists ${ $prefs->{$person2} }{$_} } keys %{ $prefs->{$person1} };

    return 0 unless scalar keys %$common;

    my $sum = sum
      map { ( $prefs->{$person1}{$_} - $prefs->{$person2}{$_} )**2 }
      keys %$common;

    return 1 / ( 1 + $sum );
}

sub sim_pearon {
    my ( $prefs, $person1, $person2 ) = @_;
    my $common;

    map { $common->{$_} = 1 }
      grep { exists ${ $prefs->{$person2} }{$_} } keys %{ $prefs->{$person1} };

    my $n = keys %$common;

    return 0 unless $n;

    my $sum1 = sum map { $prefs->{$person1}{$_} } keys %$common;
    my $sum2 = sum map { $prefs->{$person2}{$_} } keys %$common;

    my $sum1sq = sum map { ( $prefs->{$person1}{$_} )**2 } keys %$common;
    my $sum2sq = sum map { ( $prefs->{$person2}{$_} )**2 } keys %$common;

    my $psum =
      sum map { $prefs->{$person1}{$_} * $prefs->{$person2}{$_} } keys %$common;

    my $num = $psum - ( $sum1 * $sum2 / $n );
    my $den = sqrt( ( $sum1sq - $sum1**2 / $n ) * ( $sum2sq - $sum2**2 / $n ) );

    return 0 unless $den;

    return $num / $den;
}

sub topMatches {
    my ( $prefs, $person, $n, $sim_func ) = @_;
    $n        = $n        ? $n        : 5;
    $sim_func = $sim_func ? $sim_func : \&sim_pearon;

    my @scores = reverse
      sort { $a->[0] <=> $b->[0] }
      map { [ $sim_func->( $prefs, $person, $_ ), $_ ] }
      grep { $_ ne $person }
      keys %$prefs;

    return splice @scores, 0, $n;
}

sub match_all {
    my ( $prefs, $func ) = @_;

    for my $p1 ( keys %$prefs ) {
        for my $p2 ( keys %$prefs ) {
            say "$p1 : $p2 = ", $func->( $prefs, $p1, $p2 );
        }
    }
}

say Dumper [ topMatches( $critics, 'Toby', 3, \&sim_distance ) ];
say Dumper [ topMatches( $critics, 'Toby', 3 ) ];
match_all( $critics, \&sim_distance );