Ähnlichkeitssuche: Fuzzy-Search-Unit???

[leddl]

Hm, komisch. Bei mir hat das immer ganz gut funktioniert. Sicher, daß der gesuchte Begriff auch enthalten ist? Vielleicht hast du halt immer als 2. Item einen recht ähnlichen String.

//Edit:
Also weil du mich jetzt verunsichert hast, hab ich mich hingehockt und es mal ausprobiert. Funktioniert bei mir immer noch genau so, wie es soll. Selbst bei Verunstaltung der Wörter bekomme ich immer noch den richtigen Index angezeigt.

//Edit2:
Mist, jetzt hab ich grade erst deinen Zusatz gesehen. OK, dann halt noch ein Edit.
Was meintest du damit? Die Ausgabe bekommst du hin, indem du aus den TStrings denjenigen ausliest, dessen Index zurückgeliefert wird. Levenshtein liefert dir immer nur ein - das beste - Ergebnis zurück und nicht mehrere, falls du das wolltest. Evtl kann man den Algorithmus aber auch so umbügeln, daß er alle Strings, die eine geringere Distanz als x haben in ein TStrings packt und zurückgibt. Sollte auch nicht allzuviel Aufwand bereiten.

Delphi-Quellcode:

function Similarest(aText: string; aList: TStrings; Treshold: Integer): TStrings; 
var 
  Dummy: string; 
  MinV : Integer; 
  i    : Integer; 
  FiR0 : Integer; 
  FiP0 : Integer; 
  FiQ0 : Integer; 
  Dist : array of Integer; 

  { ---  Similarest: Subprozedure  ------------------------------------------- } 
  procedure LevenshteinPQR(p,q,r:integer); 
  begin 
    FiP0 := p; 
    FiQ0 := q; 
    FiR0 := r; 
  end; {  LevenshteinPQR  } 


  { ---  Similarest: Subfunktion  -------------------------------------------- } 
  function LevenshteinDistance(const sString,sPattern: String): Integer; 
  const 
    MAX_SIZE = 50; 
  var 
    aiDistance: array [0..MAX_SIZE,0..MAX_SIZE] of Integer; 
    i,j, 
    iP,iQ,iR,iPP, 
    iStringLength, 
    iPatternLength, 
    iMaxI,iMaxJ    : Integer; 
    chChar         : Char; 

    function Min(X,Y,Z: Integer): Integer; 
    begin 
      if (X<Y) then 
        Result:=X 
      else 
        Result:=Y; 
      if (Result>Z) then 
        Result:=Z; 
    end; {  Min  } 

  begin 
    iStringLength:=length(sString); 
    if (iStringLength>MAX_SIZE) then 
      iMaxI:=MAX_SIZE 
    else 
      iMaxI:=iStringLength; 
    iPatternLength:=length(sPattern); 
    if (iPatternLength>MAX_SIZE) then 
      iMaxJ:=MAX_SIZE 
    else 
      iMaxJ:=iPatternLength; 

    aiDistance[0, 0]:=0; 
    for i:=1 to iMaxI do 
      aiDistance[i, 0]:=aiDistance[i-1, 0]+FiR0; 
    for j:=1 to iMaxJ do begin 
      chChar:=sPattern[j]; 
      if ((chChar='*') or (chChar='?')) then 
        iP:=0 
      else 
        iP:=FiP0; 
      if (chChar='*') then 
        iQ:=0 
      else 
        iQ:=FiQ0; 
      if (chChar='*') then 
        iR:=0 
      else 
        iR:=FiR0; 

      aiDistance[0, j]:=aiDistance[0, j-1]+iQ; 

      for i:=1 to iMaxI do begin 
        if (sString[i]=sPattern[j]) then 
          iPP:=0 
        else 
          iPP:=iP; 
        {*** aiDistance[i,j] := Minimum of 3 values ***} 
        aiDistance[i,j]:=Min(aiDistance[i-1, j-1]+iPP, 
                             aiDistance[i, j-1]  +iQ, 
                             aiDistance[i-1, j]  +iR); 
      end; 
    end; 
    Result:=aiDistance[iMaxI, iMaxJ]; 
  end; {  LevenshteinDistance  } 
begin 
  SetLength(Dist, aList.Count); 
  LevenshteinPQR(1, 1, 1); 

  for i := 0 to (aList.Count-1) do 
  begin 
    //Dummy := ExtractFileName(aList.Strings[i]); 
    //Dummy := Copy(Dummy, 1, Pos('.', Dummy)-1); 
    Dummy := aList.Strings[i]; 

    Dist[i] := LevenshteinDistance(aText, Dummy); 
  end; 

  for i := 0 to (Length(Dist)-1) do 
    if (Dist[i] < Treshold) then Result.Items.Add(aList[i]);
    //Evtl hier noch zur Data-Eigenschaft die Distanz hinzufügen
end;

Ungetestet, sollte aber funktionieren.

[romber]

Hallo!

Nochmal vielen Dank für eure Mühe, werde mir die Lösungen jetzt mal anschauen.

[schöni]

Hallo Leddl!

Habe Deine zweite Version mit TStrings als Ergebnistyp runtergeladen. Krige aber Zugriffsverletzung.

Ist Thershold die von mir gewünschte prozentuale Übereinstimmung? Dann müßte ich ja dort einen Wert zwischen 1 und 100 eingeben.

Zitat von leddl:

Was meintest du damit? Die Ausgabe bekommst du hin, indem du aus den TStrings denjenigen ausliest, dessen Index zurückgeliefert wird.

Ja, ich will die Ausgabe der gefundenen Strings in eine Stringliste.

Hier mein Quelltext. Die Funktion Similarest habe ich in MatchList umbenannt. Den Algo habe ich unverändert übernommen:

Delphi-Quellcode:

unit Levsearch;

interface

uses SysUtils, Classes;

function MatchList(aText: string; aList: TStrings; Treshold: Integer): TStrings;

implementation

{$I Version.inc}

{$ifdef Delphi1To3}

//Da ich das ganze mit Delphi3 mache, habe ich das dynamische Array für die Variable Dist
//wie folgt, definiert:

type
  TDynamicIntegerArray = class(TStringList) //Ist halt ne gut implementierte Liste
  private
    procedure setContents(Index,value: Integer);
    function getContents(Index: Integer): Integer;
  public
    constructor Create;
    constructor Dim(value: Integer);
    property Contents[Index: Integer]: Integer read getContents write setContents; default;
  end;

constructor TDynamicIntegerArray.Create;
begin
   inherited Create;
end;

constructor TDynamicIntegerArray.Dim(value: Integer);
var i: Integer;
begin
   for i:=1 to value do
     Add(IntToStr(0))
end;

procedure TDynamicIntegerArray.setContents(Index,value: Integer);
begin
   if value <> StrToInt(Strings[Index]) then Insert(Index,IntToStr(Value));
end;

//Die Umwandlungen StrToInt u. IntToStr sind halt drin, weil ich mit ner Stringliste 
//Integerwerte speichern und bearbeiten will. Nicht optimal, aber funzt erst mal. 
//Kann später noch verbessert werden.

function TDynamicIntegerArray.getContents(Index: Integer): Integer;
begin
   Result := StrToInt(Strings[Index]);
end;
{$endif}

function MatchList(aText: string; aList: TStrings; Treshold: Integer): TStrings;
var
  Dummy: string;
  MinV : Integer;
  i    : Integer;
  FiR0 : Integer;
  FiP0 : Integer;
  FiQ0 : Integer;
  {$ifdef Delphi1To3}
  //Dist : TDynamicIntegerArray;
  {$else}
  Dist : array of Integer;
  {$endif}
  ResultList : TStringList;

  { ---  MatchList: Subprozedure  ------------------------------------------- }
  procedure LevenshteinPQR(p,q,r:integer);
  begin
    FiP0 := p;
    FiQ0 := q;
    FiR0 := r;
  end; {  LevenshteinPQR  }


  { ---  MatchList: Subfunktion  -------------------------------------------- }
  function LevenshteinDistance(const sString,sPattern: String): Integer;
  const
    MAX_SIZE = 50;
  var
    aiDistance: array [0..MAX_SIZE,0..MAX_SIZE] of Integer;
    i,j,
    iP,iQ,iR,iPP,
    iStringLength,
    iPatternLength,
    iMaxI,iMaxJ    : Integer;
    chChar         : Char;

    function Min(X,Y,Z: Integer): Integer;
    begin
      if (X<Y) then
        Result:=X
      else
        Result:=Y;
      if (Result>Z) then
        Result:=Z;
    end; {  Min  }

  begin
    ResultList := TStringList.Create;
    //Vorher Zugriffsverletzung, was ja der Gegenstand meiner Frage ist

    iStringLength:=length(sString);
    if (iStringLength>MAX_SIZE) then
      iMaxI:=MAX_SIZE
    else
      iMaxI:=iStringLength;
    iPatternLength:=length(sPattern);
    if (iPatternLength>MAX_SIZE) then
      iMaxJ:=MAX_SIZE
    else
      iMaxJ:=iPatternLength;

    aiDistance[0, 0]:=0;
    for i:=1 to iMaxI do
      aiDistance[i, 0]:=aiDistance[i-1, 0]+FiR0;
    for j:=1 to iMaxJ do begin
      chChar:=sPattern[j];
      if ((chChar='*') or (chChar='?')) then
        iP:=0
      else
        iP:=FiP0;
      if (chChar='*') then
        iQ:=0
      else
        iQ:=FiQ0;
      if (chChar='*') then
        iR:=0
      else
        iR:=FiR0;

      aiDistance[0, j]:=aiDistance[0, j-1]+iQ;

      for i:=1 to iMaxI do begin
        if (sString[i]=sPattern[j]) then
          iPP:=0
        else
          iPP:=iP;
        {*** aiDistance[i,j] := Minimum of 3 values ***}
        aiDistance[i,j]:=Min(aiDistance[i-1, j-1]+iPP,
                             aiDistance[i, j-1]  +iQ,
                             aiDistance[i-1, j]  +iR);
      end;
    end;
    Result:=aiDistance[iMaxI, iMaxJ];
  end; {  LevenshteinDistance  }
begin
  {$ifdef Delphi1To3}
  Dist := TDynamicIntegerArray.Dim(aList.Count); //Dim ist Constructor
  {$else}
  SetLength(Dist, aList.Count);
  {$endif}
  LevenshteinPQR(1, 1, 1);

  for i := 0 to (aList.Count-1) do
  begin
    //Dummy := ExtractFileName(aList.Strings[i]);
    //Dummy := Copy(Dummy, 1, Pos('.', Dummy)-1);
    Dummy := aList.Strings[i];

    Dist[i] := LevenshteinDistance(aText, Dummy);
  end;

  {$ifdef Delphi1To3}
  for i := 0 to Dist.Count-1 do
  {$else}
  for i := 0 to (Length(Dist)-1) do
  {$endif}
    if (Dist[i] < Treshold) then ResultList.Add(aList[i]);
    //Jetzt kommt hie ein EStringListError. Wieso das denn? Hab doch die Liste erzeugt
    //Evtl hier noch zur Data-Eigenschaft die Distanz hinzufügen
  Result := ResultList;
end;

end.

//Und nun mein Testformular:

{$i version.inc}  
//Hier stehen Definitionen, die die Delphiversionen voneinander unterscheiden
//Da steht auch der Wert Delphi1To3 drin

unit winSearch;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  LevSearch, Buttons, StdCtrls;

type
  TForm1 = class(TForm)
    edSearch: TEdit;
    Label1: TLabel;
    Memo: TMemo;    //Damit will ich die gefundenen Zeilen anzeigen
    SpeedButton1: TSpeedButton;
    procedure SpeedButton1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private-Deklarationen }
    InpStr: TStringList;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}


procedure TForm1.SpeedButton1Click(Sender: TObject);
var Elements: TDynamicIntegerArray;
    Matchs: TStrings;
begin
//   In der folgenden Anweisung krieg ich auch ne Zugriffsverletzung
//   Memo.Lines.AddStrings(MatchList(edSearch.Text, InpStr, 40));
//   ShowMessage('Diatanz = '+IntToStr(Similarest(edSearch.Text,InpStr)));
//   Similarest zegt bei mir Distanz = 1 an Suchbegriff "Wasser"
     Matchs := MatchList(edSearch.Text, InpStr, 20);
     ShowMessage('Anzahl Elemente: ' + IntToStr(Dist.Count)); //HIER ZUGRIFFSVERLETZUNG
                                                              //WARUM???
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   InpStr := TStringList.Create;      //Die Stringliste mit dem zu durchsuchenden Text
   InpStr.Add('Das Wasser ist warm');
   InpStr.Add('Wasserleitung');
   InpStr.Add('Wasser, das aus der Wasserleitung kommt, hat Trikwasserqualität');
   InpStr.Add('Im Sommer bade ich an liebsten in kühlem Wasser');
end;

end.

Was mache ich falsch?

Während ich das schreibe fällt mir doch ein, dass in MatchList die Ergebnisstringliste noch gar nich erzeugt wurde. Damit erklär ich mir die Zugriffsverletzung.

Das ich aber jetzt EStringlistError erhalte, leuchtet mir nicht ein. Kannst Du, Leddl, oder ein danderer von Euch helfen?

schöni

[leddl]

Nein, das war natürlich Mist von mir. So funktioniert das natürlich nicht. Bin darüber heute nacht auch lange gesessen, habe aber nichts endgültiges geschafft.
Ein möglicher Funktionskopf wäre zB so:
function Similarest(aText: string; aList: TStrings; Treshold: Integer; Var aFound : TStrings): Boolean; Damit hast du die Gewissheit, daß die TStrings vom User gehandelt werden müssen. Außerdem bekommt man so als Ergebnis, ob ein String gefunden wurde.
Was die Implementierung mit Treshold (zu deutsch: Schwelle) angeht: Die Distanz der verglichenen Strings läuft intern von 0 bis 50 (50 am schlechtesten, 0 am besten). Daher kann man eben auch nur Werte bis 50 eingeben. Daran hatte ich gestern nacht auch nicht gedacht. Das muß man dann eben dementsprechend überprüfen und ändern. Evtl muß man natürlich auch darauf achten, ob man mit Treshold jetzt die Distanz oder die Qualität betrachtet. Je nachdem muß man natürlich etwas ändern.
Könnte aber so aussehen (wieder mal ungetestet):

Delphi-Quellcode:

function Similarest(aText: string; aList: TStrings; Treshold: Integer; Var aFound : TStrings): Boolean;
var 
  Dummy: string; 
  MinV : Integer; 
  i    : Integer; 
  FiR0 : Integer; 
  FiP0 : Integer; 
  FiQ0 : Integer; 
  Dist : array of Integer; 

  { ---  Similarest: Subprozedure  ------------------------------------------- } 
  procedure LevenshteinPQR(p,q,r:integer); 
  begin 
    FiP0 := p; 
    FiQ0 := q; 
    FiR0 := r; 
  end; {  LevenshteinPQR  } 


  { ---  Similarest: Subfunktion  -------------------------------------------- } 
  function LevenshteinDistance(const sString,sPattern: String): Integer; 
  const 
    MAX_SIZE = 50; 
  var 
    aiDistance: array [0..MAX_SIZE,0..MAX_SIZE] of Integer; 
    i,j, 
    iP,iQ,iR,iPP, 
    iStringLength, 
    iPatternLength, 
    iMaxI,iMaxJ    : Integer; 
    chChar         : Char; 

    function Min(X,Y,Z: Integer): Integer; 
    begin 
      if (X<Y) then 
        Result:=X 
      else 
        Result:=Y; 
      if (Result>Z) then 
        Result:=Z; 
    end; {  Min  } 

  begin 
    iStringLength:=length(sString); 
    if (iStringLength>MAX_SIZE) then 
      iMaxI:=MAX_SIZE 
    else 
      iMaxI:=iStringLength; 
    iPatternLength:=length(sPattern); 
    if (iPatternLength>MAX_SIZE) then 
      iMaxJ:=MAX_SIZE 
    else 
      iMaxJ:=iPatternLength; 

    aiDistance[0, 0]:=0; 
    for i:=1 to iMaxI do 
      aiDistance[i, 0]:=aiDistance[i-1, 0]+FiR0; 
    for j:=1 to iMaxJ do begin 
      chChar:=sPattern[j]; 
      if ((chChar='*') or (chChar='?')) then 
        iP:=0 
      else 
        iP:=FiP0; 
      if (chChar='*') then 
        iQ:=0 
      else 
        iQ:=FiQ0; 
      if (chChar='*') then 
        iR:=0 
      else 
        iR:=FiR0; 

      aiDistance[0, j]:=aiDistance[0, j-1]+iQ; 

      for i:=1 to iMaxI do begin 
        if (sString[i]=sPattern[j]) then 
          iPP:=0 
        else 
          iPP:=iP; 
        {*** aiDistance[i,j] := Minimum of 3 values ***} 
        aiDistance[i,j]:=Min(aiDistance[i-1, j-1]+iPP, 
                             aiDistance[i, j-1]  +iQ, 
                             aiDistance[i-1, j]  +iR); 
      end; 
    end; 
    Result:=aiDistance[iMaxI, iMaxJ]; 
  end; {  LevenshteinDistance  } 
begin 
  //Treshold von 0-50
  Treshold := max(Treshold,0);
  Treshold := min(Treshold,50);

  SetLength(Dist, aList.Count); 
  LevenshteinPQR(1, 1, 1); 

  for i := 0 to (aList.Count-1) do 
  begin 
    //Dummy := ExtractFileName(aList.Strings[i]); 
    //Dummy := Copy(Dummy, 1, Pos('.', Dummy)-1); 
    Dummy := aList.Strings[i]; 

    Dist[i] := LevenshteinDistance(aText, Dummy); 
  end; 

  for i := 0 to (Length(Dist)-1) do
    if (Dist[i] < Treshold) then aFound.Items.Add(aList[i]); 

  Result := aFound.Count > 0;
end;

Treshold gibt jetzt hier die maximale Distanz der Ergebnisse an!

[schöni]

Hallo Leddl!

Erst mal Danke für die Änderung. Keine Exception mehr. Jetzt findet der Algo aber immer die ersten beiden Zeilen der Eingabeliste.

Beispiel:

Suchwort "Sommer"

Suchergebnis:
Das Wasser ist warm
Wasserleitung'

Wenn ich Wasser eingebe, wär das ja richtig. Aber bei "Sommer" erwarte ich als Ergebnis:

Im Sommer bade ich an liebsten in kühlem Wasser

Hier noch mal mein Eingabetext, der durchsucht wird:

Das Wasser ist warm
Wasserleitung
Wasser, das aus der Wasserleitung kommt, hat Trikwasserqualität
Im Sommer bade ich an liebsten in kühlem Wasser

Wenn ich als Suchbegriff "Baden" eingebe, erhalte ich auch die ersten beiden Zeilen, in denen das Wort Bad, baden o.ä. gar nicht vorkommt.

So wie ich den Algo verstehe, nimmt er je Textzeile einige Buchstaben meiner Mustereingabe und vergleicht diese mit je einer Zeile des durchsuchten Textes. Semantische Zusammenhänge werden so nicht erkannt. Sonst wäre "Das Wasser ist warm" ja als Treffer zu werten, da im Sommer das Wasser warm ist. Aber wenn nur Buchstaben verglichen werden? Irgendwas stimmt noch nicht! Auch wenn ich das Wort "Trinkwasserqualität" eingebe, erhalte ich die oben genannte Ausgabe.

schöni

[schöni]

Hallo Leddl!

Im Test hatte ich Treshold = 25

Bei Treshold = 0 findet er gar nix.

Bei Treshold = 42 findet er neben den ersten beiden Zeilen noch die folgende Zeile, was ja schon mal gut aussieht:

Im Sommer bade ich an liebsten in kühlem Wasser

Gibt es einen Optimalen Wert für Treshold? Ich werde inzwischen mal mit unterschiedlichen Werten experimentieren.

Erst mal Danke für die bisherige Hilfe

schöni

[leddl]

Wie gesagt, ich hatte meine Abänderung weder getestet, noch habe ich den ursprünglichen Algorithmus geschrieben. Daher ist das ganze natürlich sehr fehleranfällig. Außerdem hab ich mir für die Überarbeitung auch nicht gerade viel Zeit gelassen. Das war eher so hopplahopp.
Semantische Zusammenhänge kann dieser Algorithmus auf gar keinen Fall erkennen. Ich denke, für so etwas bräuchte man dann schon eine "etwas" umfangreichere Implementierung.

Versuch mal, die Funktion nur mit einzelnen Wörtern als Items zu füttern. Soweit ich das verstehe, überprüft er nämlich das Item als solches, und nicht auch Teile als solches. Übergibst du ganze Zeilen, hast du dann nämlich das Problem, daß eine längere Zeile natürlich auch eine Übereinstimmung mit größerer Distanz ergibt, selbst wenn das gesuchte Wort vorhanden ist. Eine kürzere Zeile mit einem nur bedingt ähnlichem Wort kann dann sogar evtl zu einem besseren Ergebnis führen.
Das ist jetzt nur geraten, da ich es jetzt auch nicht genau getestet habe, aber schau dir doch mal deine Zeilen an. Die ersten beiden, die Sommer nicht enthalten, sind recht kurz und könnten daher ähnlicher sein als die beiden anderen längeren Zeilen.

Und nochmal zur Verdeutlichung: Treshold = 0 ist am genauesten. Dabei sollten eigentlich nur noch sehr geringfügige Änderungen erkannt werden. Treshold = 50 läßt eigentlich fast alles zu.
Ich würde dir empfehlen, einen Wert so umdie 5 zu nehmen. Is jetzt aber auch nur geschätzt. Vielleicht reicht auch schon weniger. Teste es einfach mal aus.