excel - VBA 中的加权 Damerau-Levenshtein

Question

我正在为 Microsoft Office 套件构建一个私有(private)拼写检查器。我正在对拼写错误及其潜在修复进行字符串比较，以确定我想要包含哪些更正。

我对用于字符串比较的加权 Damerau-Levenshtein 公式进行了高低对比，因为我希望交换、插入、删除和替换都具有不同的权重，而不仅仅是“1”的权重”，因此我可以优先考虑某些更正。例如，拼写错误“agmes”理论上可以更正为“games”或“ages”，因为两者都只需要一次编辑即可移动到拼写正确的单词，但我想给出“交换”编辑较低的权重，以便“游戏”将显示为首选修正。

我使用 Excel 进行分析，因此我使用的任何代码都需要使用 Visual Basic for Applications (VBA)。我能找到的最好的是this example ，这看起来很棒，但它是用 Java 编写的。我尽了最大努力进行转换，但我距离专家还很远，需要一些帮助!

任何人都可以看一下所附的代码并帮助我找出问题所在吗？

谢谢!

编辑:我自己让它工作。这是 VBA 中的加权 Damerau-Levenshtein 公式。它使用 Excel 的内置数学函数进行某些评估。将一个拼写错误与两个可能的更正进行比较时，成本最高的更正是首选单词。这是因为两次交换的成本必须大于删除和插入的成本，如果您分配成本最低的交换(我认为这是理想的)，这是不可能的。如果您需要更多信息，请查看 Kevin 的博客。

Public Function WeightedDL(source As String, target As String) As Double

    Dim deleteCost As Double
    Dim insertCost As Double
    Dim replaceCost As Double
    Dim swapCost As Double

    deleteCost = 1
    insertCost = 1.1
    replaceCost = 1.1
    swapCost = 1.2

    Dim i As Integer
    Dim j As Integer
    Dim k As Integer

    If Len(source) = 0 Then
        WeightedDL = Len(target) * insertCost
        Exit Function
    End If

    If Len(target) = 0 Then
        WeightedDL = Len(source) * deleteCost
        Exit Function
    End If

    Dim table() As Double
    ReDim table(Len(source), Len(target))

    Dim sourceIndexByCharacter() As Variant
    ReDim sourceIndexByCharacter(0 To 1, 0 To Len(source) - 1) As Variant

    If Left(source, 1) <> Left(target, 1) Then
        table(0, 0) = Application.Min(replaceCost, (deleteCost + insertCost))
    End If

    sourceIndexByCharacter(0, 0) = Left(source, 1)
    sourceIndexByCharacter(1, 0) = 0

    Dim deleteDistance As Double
    Dim insertDistance As Double
    Dim matchDistance As Double

    For i = 1 To Len(source) - 1

        deleteDistance = table(i - 1, 0) + deleteCost
        insertDistance = ((i + 1) * deleteCost) + insertCost

        If Mid(source, i + 1, 1) = Left(target, 1) Then
            matchDistance = (i * deleteCost) + 0
        Else
            matchDistance = (i * deleteCost) + replaceCost
        End If

        table(i, 0) = Application.Min(Application.Min(deleteDistance, insertDistance), matchDistance)
    Next

    For j = 1 To Len(target) - 1

        deleteDistance = table(0, j - 1) + insertCost
        insertDistance = ((j + 1) * insertCost) + deleteCost

        If Left(source, 1) = Mid(target, j + 1, 1) Then
            matchDistance = (j * insertCost) + 0
        Else
            matchDistance = (j * insertCost) + replaceCost
        End If

        table(0, j) = Application.Min(Application.Min(deleteDistance, insertDistance), matchDistance)
    Next

    For i = 1 To Len(source) - 1

        Dim maxSourceLetterMatchIndex As Integer

        If Mid(source, i + 1, 1) = Left(target, 1) Then
            maxSourceLetterMatchIndex = 0
        Else
            maxSourceLetterMatchIndex = -1
        End If

        For j = 1 To Len(target) - 1

            Dim candidateSwapIndex As Integer
            candidateSwapIndex = -1

            For k = 0 To UBound(sourceIndexByCharacter, 2)
                If sourceIndexByCharacter(0, k) = Mid(target, j + 1, 1) Then candidateSwapIndex = sourceIndexByCharacter(1, k)
            Next

            Dim jSwap As Integer
            jSwap = maxSourceLetterMatchIndex

            deleteDistance = table(i - 1, j) + deleteCost
            insertDistance = table(i, j - 1) + insertCost
            matchDistance = table(i - 1, j - 1)

            If Mid(source, i + 1, 1) <> Mid(target, j + 1, 1) Then
                matchDistance = matchDistance + replaceCost
            Else
                maxSourceLetterMatchIndex = j
            End If

            Dim swapDistance As Double

            If candidateSwapIndex <> -1 And jSwap <> -1 Then

                Dim iSwap As Integer
                iSwap = candidateSwapIndex

                Dim preSwapCost
                If iSwap = 0 And jSwap = 0 Then
                    preSwapCost = 0
                Else
                    preSwapCost = table(Application.Max(0, iSwap - 1), Application.Max(0, jSwap - 1))
                End If

                swapDistance = preSwapCost + ((i - iSwap - 1) * deleteCost) + ((j - jSwap - 1) * insertCost) + swapCost

            Else
                swapDistance = 500
            End If

            table(i, j) = Application.Min(Application.Min(Application.Min(deleteDistance, insertDistance), matchDistance), swapDistance)

        Next

        sourceIndexByCharacter(0, i) = Mid(source, i + 1, 1)
        sourceIndexByCharacter(1, i) = i

    Next

    WeightedDL = table(Len(source) - 1, Len(target) - 1)

End Function

Answer 1

我可以看到你自己回答了这个问题:几年前我编写了一个修改后的 Levenshtein 编辑距离算法来进行地址匹配(该网站现在托管在俄罗斯，去那里不是一个好主意)，但这并没有表现良好，“公共(public)字符串之和”方法足以完成手头的任务:

Fuzzy-Matching strings in Excel using a simplified 'Edit Distance' proxy in VBA

该代码可能需要重新测试和重新工作。

查看您的代码，如果您想重新访问它，这里有速度提示:

Dim arrByte() As Byte Dim byteChar As Byte 
arrByte = strSource
for i = LBound(arrByte) To UBound(arrByte) Step 2    byteChar = arrByte(i)     ' I'll do some comparison operations using integer arithmetic on the charNext i

即使您使用 Mid$() 而不是 Mid()，VBA 中的字符串处理也非常慢，但数字操作非常好:并且字符串实际上是字节数组，编译器将按面值接受。

循环中 2 的“步骤”是跳过 unicode 字符串中的高位字节 - 您可能在普通 ASCII 文本上运行字符串比较，并且您“你会看到(比如说)“ABCd”的字节数组是(00, 65, 00, 66, 00, 67, 00, 100)。西欧国家的大多数拉丁字母(重音符号、变音符号、双元音等等)都适合 255 以下，并且不会冒险进入该 wxample 中显示为 0 的高阶字节。

在希伯来语、希腊语、俄语和阿拉伯语的严格单语字符串比较中，您将侥幸逃脱，因为每个字母表中的高位字节都是恒定的:希腊语“αβγδ”是字节数组(177 ,3,178,3,179,3,180,3)。然而，这是一种草率的编码，当您尝试跨语言进行字符串比较时，它会咬住(或字节)您。而且它永远不会用东方字母来飞翔。