K-means clustering (delphi) K - prototype

Algoritma K-means clustering

K-Means adalah teknik yang cukup sederhana dan cepat dalam pekerjaan pengelompokkan data (clustering). Prinsip utama dari teknik ini adalah menyusun k buah prototipe/pusat massa (centroid)/rata-rata (mean) dari sekumpulan data berdimensi n. Teknik ini mensyaratkan nilai k sudah diketahui sebelumnya (a priori). Algoritma k-means dimulai dengan pembentukan prototipe cluster di awal kemudian secara iteratif prototipe cluster ini diperbaiki hingga konvergen (tidak terjadi perubahan yang signifikan pada prototipe cluster). Perubahan ini diukur menggunakan fungsi objektif J yang umumnya didefinisikan sebagai jumlah atau rata-rata jarak tiap item data dengan pusat massa kelompoknya. Secara lebih detil algoritma k-means adalah seperti berikut :
inisialisasi nilai J (misal MAXINT)
Tentukan prototipe cluster awal (bisa secara acak ataupun dipilih salah satu secara acak dari koleksi data)
Masukkan tiap satuan data ke dalam kelompok yang jarak dengan pusat massa-nya paling dekat
ubah nilai pusat massa tiap cluster sebagai rata-rata (mean) dari seluruh anggota kelompok tersebut
Hitung fungsi objektif J
jika nilai J sama dengan sebelumnya, berhenti atau ulangi langkah 3
Berikut ini adalah contoh implementasi algoritma k-means dalam delphi.1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19    { garis besar kode }
type
  TTrainingData=record
    feature : array of real;
    truth : integer;
  end;

procedure DoKMeans;
begin
  Initialize;
  repeat
    Inc(NumStep);

    ReviseMinimum;
    CalculateCentroid;
    MeasureAccuracy;
    
  until IsConverge or (NumStep > MaxStep);
end;
 var
  NumStep,MaxStep : longint;
  CurJ, OldJ : double;
  Err, MinErr : double;
  NumCorrect : integer;

  proposal : array of array of integer;
  centroid : array of array of double;
  distance : array of array of double;
  solution : array of integer;

  procedure RandomPick;
  var
    p, q, r : integer;
  begin
    for p := 0 to NumClass-1 do begin
      if p = 0 then
        r := Random(Length(FData))
      else
        r := r + Random((Length(FData)-r));
        
      for q := 0 to FeatureLength-1 do
        centroid[p][q] := FData[r].feature[q];
    end;
  end;

  procedure CalculateDistanceFromCentroids;
  var
    i, j, k : integer;
    tmp : double;
  begin
    for j := 0 to High(FData) do
      for i := 0 to NumClass-1 do begin
        tmp := 0.0;
        for k := 0 to FeatureLength-1 do
          tmp := tmp + sqr(FData[j].feature[k]-centroid[i][k]);
        distance[j][i] := sqrt(tmp);
      end;
  end;

  procedure Initialize;
  var
    p : integer;
  begin
    NumStep := 0;
    MaxStep := 3000;
    MinErr  := MAXINT;
    OldJ    := MAXINT;
    
    setlength(proposal, NumClass);
    setlength(centroid, NumClass);
    for p := 0 to NumClass-1 do begin
      setlength(proposal[p], 0);
      setlength(centroid[p], FeatureLength);
    end;

    setlength(solution, Length(FData));
    setlength(distance, Length(FData));
    for p := 0 to high(FData) do
      Setlength(distance[p], NumClass);

    RandomPick;
    CalculateDistanceFromCentroids;
  end;

  procedure CalculateCentroid;
  var
    i, j, k : integer;
    NumInstances : integer;
  begin
    for j := 0 to NumClass-1 do begin
      NumInstances := 0;
      for k := 0 to FeatureLength-1 do
          centroid[j][k] := 0.0;

      for i := 0 to High(proposal[j]) do begin
        for k := 0 to FeatureLength-1 do
          centroid[j][k] := centroid[j][k] + FData[proposal[j][i]].feature[k];
        Inc(NumInstances);
      end;

      if NumInstances > 0 then
        for k := 0 to FeatureLength-1 do
          centroid[j][k] := centroid[j][k] / NumInstances;
    end;
    CalculateDistanceFromCentroids;
  end;

  function IsConverge:boolean;
  var
    i, j : integer;
  begin
    CurJ := 0;
    for i := 0 to NumClass-1 do
      for j := 0 to High(proposal[i]) do
        CurJ := CurJ + distance[proposal[i][j]][i];

    Result := (Abs(CurJ-OldJ) < 1e-2);
    OldJ := CurJ;
  end;

  procedure ReviseMinimum;
  var
    i, j, p, minidx : integer;
    min : double;
  begin
    for p := 0 to NumClass-1 do
      setlength(proposal[p], 0);
      
    for j := 0 to High(FData) do begin
      minidx := 0;
      min := distance[j][minidx];
      for i := 1 to NumClass-1 do
        if distance[j][i] < min then begin
          minidx := i;
          min := distance[j][minidx];
        end;
      setlength(proposal[minidx], length(proposal[minidx])+1);
      proposal[minidx][high(proposal[minidx])] := j;
    end;
  end;

  procedure MeasureAccuracy;
  var
    i, j : integer;
    parsolution : array of integer;
  begin
    NumCorrect := 0;
    setlength(parsolution, Length(FData));
    for i := 0 to NumClass-1 do
      for j := 0 to High(proposal[i]) do
        parsolution[proposal[i][j]] := i+1;
    
    for i := 0 to High(FData) do
      if (parsolution[i] = FData[i].truth) then
        Inc(NumCorrect);

    Err := (Length(FData)-NumCorrect) * 100 / Length(FData);
    if Err < MinErr then begin
      MinErr := Err;
      for j := 0 to High(FData) do
        solution[j] := parsolution[j];
    end;
    Setlength(parsolution, 0);
  end;