VBA中的加权Damerau-Levenshtein

Question

我正在为Microsoft Office套件构建一个私有的拼写检查程序.我正在对拼写错误进行字符串比较,以及确定我想要包含哪些更正的潜在修复方法.

对于加权 Damerau-Levenshtein公式进行字符串比较,我看起来很高和很低,因为我希望交换,插入,删除和替换都具有不同的权重,而不仅仅是"1"的权重,所以我可以优先考虑一些更正超过其他人.例如,错字"agmes"理论上可以纠正为"游戏" 或 "年龄",因为两者都只需要一个编辑就可以移动到正确拼写的单词,但我想让"交换"编辑的权重更低,所以"游戏"将显示为首选更正.

我正在使用Excel进行分析,因此我使用的任何代码都需要在Visual Basic for Applications(VBA)中.我能找到的最好的是这个例子,看起来很棒,但它是用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 编辑距离算法来进行地址匹配（该网站现在托管在俄罗斯，去那里是个坏主意）但是表现根本不好，“公共字符串之和”方法足以完成手头的任务：

\n

使用 VBA 中简化的“编辑距离”代理在 Excel 中模糊匹配字符串

\n

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

\n

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

\n\n

\nDim arrByte() 作为字节 \nDim byteChar 作为字节 \n
arrByte = strSource
\n
for i = LBound(arrByte) 转 UBound(arrByte) 步骤 2\n\xc2\xa0\xc2\xa0\xc2\xa0\xc2\xa0byteChar = arrByte(i) \xc2\xa0\xc2\xa0\xc2\xa0\ xc2\xa0\'\xc2\xa0I\'ll\xc2\xa0do\xc2\xa0some\xc2\xa0比较\xc2\xa0操作\xc2\xa0使用\xc2\xa0整数\xc2\xa0算术\xc2\xa0on\xc2\xa0the\xc2 \xa0char\n下一个\n

\n

\n

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

\n

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

\n

你会用严格的单语逃脱它，因为每个字母表中的高位字节是恒定的：希腊语“\xce\xb1\xce\xb2\xce\xb3\xce\xb4”是字节数组 (177,3,178,3,179,3,180,3)。然而，这是一种草率的编码，当您尝试跨语言进行字符串比较时，它会咬住（或字节）您。而且它永远不会以东方字母的形式飞翔。

\n