uclusterrev.pas

clusterfilesrev 最新的分类聚类代码

              i:=i+1;  
          until i > NC;

          MakeClustersMinD;
        end;

  end;   {   MakeClustersMinD   }




var
  ph,                    //  僾儕儞僞弌椡偵偍偗傞暥帤楍偺崅偝
  pw,                    //  暥帤楍偺婎杮挿
  ps : Longint;          //  僾儕儞僞弌椡偵偍偗傞墶曽岦婎杮堏摦検
  pwunit : extended;     //  嫍棧丒旕椶帡搙偺婎杮検


//   僾儕儞僞弌椡偵偍偗傞墶曽岦偺埵抲
function xpos( y : extended ) : Longint;
  begin
           xpos := 2*pw + round(ps*y/pwunit);
  end;

//  僾儕儞僞弌椡偵偍偗傞廲曽岦偺埵抲
function ypos( x : extended ) : Longint;
  begin
           ypos := round( (x+2)*ph*1.2 );
  end;

//   庽忬恾偺嵞婣揑嶌惉
procedure CheckCluster( c : PntrC );
  begin
      with Printer, Canvas do
        begin
          if c^.L = nil    //  崁栚偺昤夋弌椡
            then
              begin
                cpos:=cpos+dgap;
                c^.x:=cpos;        //  廲曽岦偺埵抲
                TextOut(xpos(0.0)-TextWidth(LObj[c^.id]+' '),
                        ypos(cpos)-(ph div 2),
                        LObj[c^.id] );
              end
            else          //  壓埵僋儔僗僞偺扵嶕
              begin
                //   嵞婣揑扵嶕
                CheckCluster( c^.L ); CheckCluster( c^.R );

                //   偙偺僋儔僗僞c^偺廲曽岦偺埵抲
                c^.x:=0.5*(c^.L^.x + c^.R^.x);

                //   僋儔僗僞c^.L^偲僋儔僗僞c^傪偮側偖
                MoveTo(xpos(c^.L^.y),ypos(c^.L^.x));
                LineTo(xpos(c^.y),   ypos(c^.L^.x));

                //   僋儔僗僞c^.R^偲僋儔僗僞c^傪偮側偖
                LineTo(xpos(c^.y),   ypos(c^.R^.x));
                LineTo(xpos(c^.R^.y),ypos(c^.R^.x));
              end;
        end;
  end;

//  庽忬恾偺嶌惉
procedure DrawTree;
  begin
      FMain.PrintDialog1.execute;
      with Printer do
        begin
          BeginDoc;

          //    僾儕儞僞偱偺婎杮僒僀僘偺愝掕
          with Canvas do
            begin
                Font.Size:=StrToIntDef(FMain.FontEdit.Text, 10); // 6; //10;
                ph:=TextHeight('X');
                pw:=TextWidth('WWWWW');
                ps:=pw;
                pwunit:=ListC[NC].p^.y/n;
                if (2+n+1)*pw > PageWidth*0.9
                  then ps:=Round((0.9*PageWidth-2*pw)) div (n+1)
            end;

          dgap:=1.0;   //  崁栚摉偨傝偺堏摦検
          cpos:=2.0;   //  崁栚偺埵抲

          with Canvas do
            begin
              //   栚惙傝偺昤夋
              MoveTo(xpos(0.0),ypos(1.5));
              LineTo(xpos(0.0),ypos(1.25));
              LineTo(xpos(ListC[NC].p^.y),ypos(1.25));
              LineTo(xpos(ListC[NC].p^.y),ypos(1.5));
              TextOut(xpos(0.0),ypos(1.7),'0.0');
              TextOut(xpos(ListC[NC].p^.y),ypos(1.7),
                      FloatToStrF(ListC[NC].p^.y,ffFixed,9,2));
              case DistType of
                     DMax   : TextOut(xpos(0.0), ypos(0.1),'嵟挿嫍棧朄');
                     DMIn   : TextOut(xpos(0.0), ypos(0.1),'嵟抁嫍棧朄');
                     DMean  : TextOut(xpos(0.0), ypos(0.1),'孮娫暯嬒朄');
              end;
            end;

          CheckCluster( ListC[NC].p);   //   庽忬恾偺嵞婣揑昤夋

          EndDoc;
        end;
  end;   {   DrawTree   }


//   僋儔僗僞偺攑婞傪嵞婣揑偵峴偆
procedure ClearC( c : PntrC );
  begin
          if c^.L = nil
            then
              begin
                dispose(c);
              end
            else
              begin
                ClearC( c^.L ); ClearC( c^.R );
                dispose(c);
              end;
  end;

//  僋儔僗僞偺攑婞
procedure ClearTree;
  begin
          ClearC( ListC[NC].p );
  end;


//  暥帤楍傪嵍媗偱巜掕偟偨挿偝L偺傕偺偵曄姺偡傞
function AdjStrL( s : string; L : integer ) : string;
  var w, i : integer;
  begin
      w:=Length(s);
      if w < L then
        for i:=1 to L-w do s:=s+' ';
      AdjStrL:=s;
  end;


//    嫍棧乮旕椶帡乯僨乕僞偵傛傞僋儔僗僞暘愅
procedure TFMain.DistButtonClick(Sender: TObject);
var i, j : integer;
begin
    //   嫍棧僨乕僞擖椡梡僼僅乕儉偺惗惉
    FDist:= TFDist.Create(Application);
    FDist.Show;
    ckFSim:=0;
    repeat
        Application.ProcessMessages;
    until ckFSim <> 0;
    ExitButton.SetFocus; UpDate;

    //    僋儔僗僞惗惉婎弨偺慖戰
    case ComboBoxDist.ItemIndex of
         0   : DistType:=DMax;
         1   : DistType:=DMean;
         2   : DistType:=DMin;
         else  begin
                 ShowMessage('DistType Error');
                 exit;
               end;
    end;

    //   撉傒崬傒僨乕僞弌椡梡僼傽僀儖柤偺愝掕
    with OpenDialog1 do
      begin
          Title:='Output File';
          FileName:='';
          if not execute then exit;
          AssignFile(outf, FileName);
      end;
    Rewrite(outf);

    //  愝掕僨乕僞偺彂偒弌偟
    writeln(outf);
    writeln(outf,'擖椡僨乕僞乮椶帡搙乯...');
    for i:=1 to n do
      begin
        write(outf, AdjStrL(LObj[i],10));
        if i > 1 then
          for j:=1 to i-1 do
            write(outf, AdjStrL(FloatToStrF(Dist[i,j],ffGeneral,7,1),10));
        writeln(outf);
      end;

    //   嫍棧儕僗僩偺嶌惉
    DistEnd:=0;
    for i:=2 to n do
      for j:=1 to i-1 do
        begin
            DistEnd:=DistEnd+1;
            with ListDist[DistEnd] do
              begin
           //       id1:=i; id2:=j;
                  id1:=j;  id2:=i;
                  d:=Dist[i,j];
              end;
        end;

    //   崁栚偵懳墳偡傞僋儔僗僞傪昞偡僆僽僕僃僋僩偺儕僗僩偺嶌惉
    NC:=n;
    for i:=1 to n do
      with ListC[i] do
        begin
            id:=i;
            new(p);
            with p^ do
              begin
                  id:=i;
                  y :=0.0;
                  L:=nil;  R:=nil;
                  for j:=1 to n do
                    if j = i then memid[j]:=1
                             else memid[j]:=0;
              end;
        end;
    serNC:=n;

    case DistType of
           DMax   :  MakeClustersMaxD;
           DMean  :  MakeClustersMeanD;
           DMin   :  MakeClustersMinD;
           else      begin
                         ShowMessage('Invalid value of DistType');
                         CloseFile(outf);
                         Close;
                     end;
    end;

    DrawTree;       //   庽忬恾偺昤夋

    ClearTree;      //   僋儔僗僞偺攑婞

    CloseFile(outf);
    ShowMessage('Calculation ended. Output File = '+
                 OpenDialog1.FileName);

    Close;
end;


//        椶帡搙僨乕僞偵婎偯偔僋儔僗僞暘愅

procedure MakeClustersMaxSim;
  var i, j, c1, c2 : integer;
      td, da, db : extended;
  begin
      with ListDist[1] do
        begin  c1:=id1; c2:=id2; td:=d;  end;
      for i:=2 to DistEnd do
        with ListDist[i] do
          if td < d then
            begin
                c1:=id1; c2:=id2; td:=d;
            end;
      NC:=NC+1;
      New(ListC[NC].p);
      serNC:=serNC+1;
      ListC[NC].id:=serNC;
      with ListC[NC].p^ do
        begin
            id:=serNC;
            L :=SeekC(c1);
            R :=SeekC(c2);
            y :=td;
        end;

      if NC > 3 then
        begin
          for i:=1 to NC-1 do
            if (ListC[i].id <> c1) and (ListC[i].id <> c2) then
              begin
                  DistEnd:=DistEnd+1;
                  with ListDist[DistEnd] do
                    begin
                        id1:=ListC[i].id;
                        id2:=serNC;
                        da:=calcD(id1,c1);
                        db:=calcD(id1,c2);
                        if da < db then d:=da else d:=db;
                    end;
              end;

          i:=1;
          repeat
            if (ListDist[i].id1 = c1) or (ListDist[i].id1 = c2) or
               (ListDist[i].id2 = c1) or (ListDist[i].id2 = c2)
               then
                 begin
                   for j:=i to DistEnd-1 do
                     ListDist[j]:=ListDist[j+1];
                     DistEnd:=DistEnd-1;
                     i:=i-1;
                 end;
            i:=i+1;
          until i >= DistEnd;

          i:=1;
          repeat
              if (ListC[i].id = c1) or (ListC[i].id = c2)
                then begin
                  if i < NC then
                    for j:=i to NC-1 do ListC[j]:=ListC[j+1];
                  NC:=NC-1;
                  i:=i-1;
                end;

              i:=i+1;
          until i > NC;

          MakeClustersMaxSim;
        end;

  end;   {   MakeClustersMaxSim   }



procedure MakeClustersMeanSim;
  var i, j, c1, c2, k, nmem : integer;
      td, sumd : extended;
  begin
      with ListDist[1] do
        begin  c1:=id1; c2:=id2; td:=d;  end;
      for i:=2 to DistEnd do
        with ListDist[i] do
          if td < d then
            begin
                c1:=id1; c2:=id2; td:=d;
            end;
      NC:=NC+1;
      New(ListC[NC].p);
      serNC:=serNC+1;
      ListC[NC].id:=serNC;
      with ListC[NC].p^ do
        begin
            id:=serNC;
            L :=SeekC(c1);
            R :=SeekC(c2);
            y :=td;
            for i:=1 to N do
              if (L^.memid[i])+(R^.memid[i]) > 0 then memid[i]:=1
                                                 else memid[i]:=0;
        end;

      if NC > 3 then
        begin
          for i:=1 to NC-1 do
            if (ListC[i].id <> c1) and (ListC[i].id <> c2) then
              begin
                  DistEnd:=DistEnd+1;
                  with ListDist[DistEnd] do
                    begin
                        id1:=ListC[i].id;
                        id2:=serNC;

                        sumd:=0.0;  nmem:=0;
                        for j:=1 to n do
                          for k:=1 to n do
                            if ListC[i].p^.memid[j]
                               * ListC[NC].p^.memid[k] <> 0
                                then
                                  begin
                                    if j > k then sumd:=sumd+Sim[j,k]
                                             else sumd:=sumd+Sim[k,j];
                                    nmem:=nmem+1;
                                  end;
                        d:=sumd/nmem;
                    end;
              end;

          i:=1;
          repeat
            if (ListDist[i].id1 = c1) or (ListDist[i].id1 = c2) or
               (ListDist[i].id2 = c1) or (ListDist[i].id2 = c2)
               then
                 begin
                   for j:=i to DistEnd-1 do
                     ListDist[j]:=ListDist[j+1];
                     DistEnd:=DistEnd-1;
                     i:=i-1;
                 end;