Re: k-Means Clustering demo program with Tk

[zentara]

I will just mention that on my system, your labels get text clipped off of the ends. It is probably due to you using a set window size, along with the place method for packing. Then if the font size is different on a different system, it dosn't setup right. The "pack" method will handle these adjustments automatically. Also pack will allow a nice resizing. Check out this version using pack

#!/usr/bin/perl -w
# k Means demo program
# Adapted from a VB program by Kardi Teknomo
# http://people.revoledu.com/kardi/tutorial/kMean/index.html
# Ported to Perl/Tk by bart @ Perlmonks

use strict;


# ----------------------- Tk interface -------------------------
use Tk;
my $mw = MainWindow->new( -title => "k Means Clustering, adapted from 
+tutorial by Kardi Teknomo" );

my $topframe = $mw->Frame()->pack();
my $butframe = $mw->Frame()->pack();
my $mainframe = $mw->Frame()->pack(-fill => 'both', -expand=> 1);

$topframe->Label(
      -text => "Click data in the canvas below. The program will autom
+atically cluster the data by color code."
    )->pack();

$butframe->Label(-text => "Number of clusters")->pack(-side =>'left',-
+padx => 5);

my $clusters_entry = $butframe->Entry(-relief => "sunken", -disabledfo
+reground => 'darkgray');
$clusters_entry->pack(-side=>'left');
$clusters_entry->insert('end', '3');


my $button_reset = $butframe->Button(-text => "Clear Data", 
     -relief => "raised", 
     -command => \&reset_click)->pack(-side=>'left', -padx=>10);


$butframe->Label(-text => "(X, Y)", 
           -justify => 'right')->pack(-side=>'left', -padx=>10);


my $label_xy = $butframe->Label( -text => "X, Y")
                               ->pack(-side=>'left', -padx=>10);


my $canvas = $mainframe->Scrolled('Canvas', -scrollbars => '', 
               -background => 'white')->pack(-fill=>'both',-expand=>1)
+;

$canvas->CanvasBind( "<ButtonPress-1>", [ \&canvas_click, Ev('x'), Ev(
+'y')]);
$canvas->CanvasBind( "<Motion>", [ \&canvas_mousemove, Ev('x'), Ev('y'
+)]);
$canvas->CanvasBind( "<Leave>", [ \&canvas_mouseleave ]);


#----------------------- Event Handlers ------------------------

my @color = qw(red yellow green cyan blue purple gray magenta pink
  chartreuse coral darkolivegreen);
# If you want to be able to have more clusters, add more colours.


my(%point, @cluster, $dataset);

sub reset_click {
   $canvas->delete('all');
   (@cluster, %point, $dataset) = ();
   $clusters_entry->configure(-state => 'normal');
}

sub canvas_mousemove {
    my $canvas = shift;
    my($x, $y) = @_;
    my $x1 =  sprintf('%.3d', $x);
    my $y1 =  sprintf('%.3d', $y); 
    $label_xy->configure(-text => "($x1,$y1)");
}

sub canvas_mouseleave {
    my $canvas = shift;
    my $x1 =  sprintf('%.3d', 0);
    my $y1 =  sprintf('%.3d', 0); 
    $label_xy->configure(-text => "($x1,$y1)");
}

sub canvas_click {
    my $canvas = shift;
    my($x, $y) = @_;
    if(!$dataset) {
        my $clusters = $clusters_entry->get;
        if($clusters !~ /^\d+$/ or $clusters == 0 or $clusters > @colo
+r) {
            warn "Not a valid value for cluster count";
            return;
        }
        $dataset  = Data::Cluster::kMean->new(0+$clusters) or die "Fai
+led to make object";
        $clusters_entry->configure(-state => 'disabled');
    }
    $dataset->add(my $point = [ $x, $y ]);
    # A point is an array ref with coordinates
    my %record = ( data => $point, cluster => -1 );
    $record{id} = $canvas->createLine($x, $y, $x, $y,
      -fill => 'red', -width => 8,
      -capstyle => 'round', -tags => ['dot'],
    );
    # Keep track of point properties using a stringified reference to 
+the point coordinates array
    $point{$point} = \%record;

    foreach my $cluster ($dataset->clusters) {
        my $i = $cluster->index;
        my $r = $cluster[$i] ||= { obj => $cluster, id =>
          $canvas->createText($x, $y, -anchor => 'c', -width => 150, t
+ag => 'label',
            -text => 1+$i) };

        # Move centroid label
        my($x, $y) = @{$cluster->centroid};
        $canvas->coords($r->{id}, $x, $y);

        # Colour dots according to cluster
        foreach my $p ($cluster->points) {
            if($point{$p}{cluster} != $i) {
                $point{$p}{cluster} = $i;
                $canvas->itemconfigure($point{$p}{id}, -fill => $color
+[$i]);
            }
        }
    }
    $canvas->raise('label', 'dot');
}

#------------------------ Main Program -------------------------
MainLoop;


#------------------------ kMean module -------------------------

package Data::Cluster::kMean;
use List::Util qw(sum);

sub new {
    my $class = shift;
    my($max_clusters) = @_;
    return bless { max_clusters => $max_clusters, data => [], cluster 
+=> [], clusters => [] }, $class;
}

sub add {
    # add data point(s) (array references) -- by reference, so make su
+re they're not reused for something else
    my $self = shift;
    return unless @_;
    unless(ref $_[0] eq 'ARRAY') {
        @_ = [ @_ ];
    }
    foreach my $p (@_) {
        push @{$self->{data}}, $p;
        push @{$self->{cluster}}, -1;   # not in a cluster
        if(@{$self->{clusters}} < $self->{max_clusters}) {
            my $index = @{$self->{clusters}};
            push @{$self->{clusters}}, Data::Cluster::kMean::Cluster->
+new($self, $index);
            $self->{cluster}[-1] = $index;
        } else {
            my $c;
            {
                my $j = 0;
                my $min_dist;
                for my $cluster (@{$self->{clusters}}) {
                    my $dist = _dist($p, $cluster->centroid);
                    if(!defined $min_dist or $dist < $min_dist) {
                        $c = $j;
                        $min_dist = $dist;
                    }
                } continue {
                    $j++;
                }
            }
            $self->{clusters}[$c]->invalidate;
            $self->{cluster}[-1] = $c;

            my $is_still_moving = 1;
            while($is_still_moving) {
                # this loop will surely converge

                my @centroid = map $_->centroid, @{$self->{clusters}};

                # assign all data to the new centroids
                $is_still_moving = 0;

                my $i = 0;
                for my $p (@{$self->{data}}) {
                    my $c;
                    {
                        my $min_dist;
                        for my $j (0 .. $#{$self->{clusters}}) {
                            my $dist = _dist($p, $centroid[$j]);
                            if(!defined $min_dist or $dist < $min_dist
+) {
                                $c = $j;
                                $min_dist = $dist;
                            }
                        }
                    }
                    if($c != $self->{cluster}[$i]) {
                        $self->{clusters}[$self->{cluster}[$i]]->inval
+idate;
                        $self->{clusters}[$c]->invalidate;
                        $self->{cluster}[$i] = $c;
                        $is_still_moving = 1;
                    }
                } continue {
                    $i++;
                }
            }
        }
    }
}

sub clusters {
    # Returns a list of all Cluster objects
    my $self = shift;
    return @{$self->{clusters}};
}

sub _dist {
    # function
    return sqrt(sum map { my $d = $_[0][$_]-$_[1][$_]; $d*$d } 0 .. $#
+{$_[0]});
}


package Data::Cluster::kMean::Cluster;
use List::Util qw(sum);

sub new {
    my $class = shift;
    my($parent, $index) = @_;
    bless { index => $index, data => $parent->{data}, cluster => $pare
+nt->{cluster}, centroid => undef}, $class;
}

sub points {
    # Returns a list of all points in cluster
    my $self = shift;
    my $index = $self->{index};
    my @point = @{$self->{data}}[grep $self->{cluster}[$_] == $index, 
+0 .. $#{$self->{data}}];
    return @point;
}

sub centroid {
    # Returns a point indicating the cluster's center of gravity
    my $self = shift;
    return $self->{centroid} ||= _centroid($self->points);
}

sub _centroid {
    # function
    return undef unless @_;
    my $dim = @{$_[0]};
    return [ map { my $i = $_; sum(map $_->[$i], @_) / @_ } 0 .. $dim-
+1 ];
}

sub invalidate {
    # Throw away cache
    my $self = shift;
    undef $self->{centroid};
}

sub index {
    # integer, position in cluster array of parent
    my $self = shift;
    return $self->{index};
}

1;

[bart]

The labels? Ah yes, the cause must be the difference in default font size.

But your entry text box, for the number of clusters, now looks very big, doesn't it? And you resorted to use a fixed width for the coordinates, 3 digits per coordinate, or else the widgets would jump to the left and to the right.

I really really dispise layout managers, Java's AWT is another one like that.

[zentara]

Well I just made the minimal changes to make packing work. The way you would normally do it, is pack sub-frames into frames. So I just packed the widgets to side=>left with some padding. But a better way, would be to make separate little frames, one for each label and entry combo ( or whatever), assign them default widths, and pack the frames into the frames. It's more work than I cared to do on a Sunday morning, :-) but that is how you usually do it. The trick with frame packing is to remember that the frame gets it's size from the widgets it contains, so if you want to maintain a frame's width, you must set a widget in it with a -width=>$somemin.

The sprintf on the digits was the easiest way out, but you could have set them in there own frame, set an alignment on the label packing, and give a -width to the label, to hold it steady.

Of course in a GUI app, half your time is spent making it appear and resize correctly, and pack makes that easier in the long run.

[QM]

I tried this on one machine, works great! Then I went home, tried to show it to someone, and got this message:

Bad option `-disabledforeground' at c:/Perl/site/lib/Tk/Widget.pm line
+ 196.
 at kmeans_clustering.pl line 24

I'm sure it's a version thing, this is before:

ppm> query tk
Querying target 1 (ActivePerl 5.8.0.806)
  1. Tk [800.024] A Graphical User Interface Toolkit

In the process of upgrading, but thought you'd like to know...