uclusterrev.pas

clusterfilesrev 最新的分类聚类代码

            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;

          MakeClustersMeanSim;
        end;

  end;   {   MakeClustersMeanSim   }



procedure MakeClustersMinSim;
  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;

          MakeClustersMinSim;
        end;

  end;   {   MakeClustersMinSim   }



var
  MaxSim, MaxSim0 : extended;

//   椶帡搙僨乕僞偵偍偗傞僋儔僗僞偺崅偝偺埵抲
function xposSim( y : extended ) : Longint;
  begin
           xposSim := 2*pw + round(ps*(MaxSim-y)/pwunit);
  end;


procedure CheckClusterSim( c : PntrC );
  begin
      with Printer, Canvas do
        begin
          if c^.L = nil
            then
              begin
                cpos:=cpos+dgap;
                c^.x:=cpos;

                TextOut(xposSim(MaxSim)-TextWidth(LObj[c^.id]+' '),
                        ypos(cpos)-(ph div 2),
                        LObj[c^.id] );
              end
            else
              begin
                CheckClusterSim( c^.L ); CheckClusterSim( c^.R );
                c^.x:=0.5*(c^.L^.x + c^.R^.x);

                MoveTo(xposSim(c^.L^.y),ypos(c^.L^.x));
                LineTo(xposSim(c^.y),   ypos(c^.L^.x));
                LineTo(xposSim(c^.y),   ypos(c^.R^.x));
                LineTo(xposSim(c^.R^.y),ypos(c^.R^.x));
              end;
        end;
  end;


procedure DrawTreeSim;
  begin
      FMain.PrintDialog1.execute;
      with Printer do
        begin
          BeginDoc;

          with Canvas do
            begin
                Font.Size:=StrToIntDef(FMain.FontEdit.Text, 10); //12;
                ph:=TextHeight('X');
                pw:=TextWidth('WWWWW');
                ps:=pw;
                pwunit:=MaxSim/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(xposSim(MaxSim0),ypos(1.5));
              LineTo(xposSim(MaxSim0),ypos(1.25));
              LineTo(xposSim(ListC[NC].p^.y),ypos(1.25));
              LineTo(xposSim(ListC[NC].p^.y),ypos(1.5));
              TextOut(xposSim(MaxSim0),ypos(1.7),FloatToStr(Maxsim0));
              TextOut(xposSim(ListC[NC].p^.y),ypos(1.7),
                      FloatToStrF(ListC[NC].p^.y,ffFixed,9,2));
              case DistType of
                     DMax   : TextOut(xposSim(MaxSim), ypos(0.1),
                                      '嵟挿嫍棧朄亙椶帡搙亜');
                     DMIn   : TextOut(xposSim(MaxSim), ypos(0.1),
                                      '嵟抁嫍棧朄亙椶帡搙亜');
                     DMean  : TextOut(xposSim(MaxSim), ypos(0.1),
                                      '孮娫暯嬒朄亙椶帡搙亜');
              end;
            end;

          CheckClusterSim( ListC[NC].p);

          EndDoc;
        end;
  end;   {   DrawTreeSim   }




procedure TFMain.SimButtonClick(Sender: TObject);
var i, j : integer;
begin
    FSim:= TFSim.Create(Application);
    FSim.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(Sim[i,j],ffGeneral,7,1),10));
        writeln(outf);
      end;

    DistEnd:=0;
    MaxSim0:=0.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:=Sim[i,j];
                  if MaxSim0 < d then MaxSim0:=d;
              end;
        end;
    MaxSim:=MaxSim0+MaxSim0/n;

    NC:=n;
    for i:=1 to n do
      with ListC[i] do
        begin
            id:=i;
            new(p);
            with p^ do
              begin
                  id:=i;
                  y :=MaxSim;
                  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   :  MakeClustersMaxSim;
           DMean  :  MakeClustersMeanSim;
           DMin   :  MakeClustersMinSim;
           else      begin
                         ShowMessage('Invalid value of DistType');
                         CloseFile(outf);
                         Close;
                     end;
    end;

    DrawTreeSim;

    ClearTree;

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

    Close;
end;

//    嵗昗抣僨乕僞偺僋儔僗僞暘愅
procedure TFMain.CoordButtonClick(Sender: TObject);
var i, j : Longint;

  function StrToL( s : string; L : Longint ) : string;
    var w, i : Longint;
    begin
        w:=Length(s);
        if w < L then
          for i:=1 to L-w do s:=s+' ';
        StrToL:=s;
    end;

begin
    //   懏惈抣僨乕僞擖椡梡僼僅乕儉偺惗惉
    FCoord:= TFCoord.Create(Application);
    FCoord.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;

    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 = '+
                 UInCoord.FCoord.OpenDialog1.FileName);

    Close;
end;

end.