algorithm – 如何删除可以从图形数据线性插值的所有点？

2023年4月30日 199次阅读

给定Excel中的两列图形数据,它如何“非插值” – 即压缩到产生相同折线图的最少行数？

一个简单的例子：

x    y
1    4
2    5
3    6
4    3
5    0

会成为：

x    y
1    4
3    6
5    0

…因为这会产生完全相同的线,但删除了“中间”点.

是否存在可用于产生此类结果的现有宏,加载项,在线工具等 – 或者如果没有,或许有人可以发明这样的算法？

编辑：对于一个真实的例子,下图是使用WebPlotDigitizer进行逆向工程的.粉红点标记了点,这些点可能没有完美地转换为浮点值 – 所以理想情况下算法会包含一个小的“误差幅度” “说明这一点.

最佳答案 你能试试吗？

Sub RemoveLinearlyDependentPoints()

    Dim rngX As Range, rngY As Range, rngData As Range, rngRemove As Range
    Dim lCount As Long, dSlope1 As Double, dSlope2 As Double
    Dim varX As Variant, varY As Variant
    Const EPSILON = 0.0001

    ' Change ranges as needed
    Set rngX = Range("A1:A5")
    Set rngY = Range("B1:B5")
    Set rngData = Union(rngX, rngY)

    rngData.Sort key1:=rngX, Order1:=xlAscending

    ' Working with arrays instead of ranges is faster,
    ' can make a big different for large datasets
    varX = rngX.Value
    varY = rngY.Value

    With WorksheetFunction
        For lCount = 1 To rngX.Count - 2
            dSlope1 = .Slope(Array(varX(lCount, 1), varX(lCount + 1, 1)), Array(varY(lCount, 1), varY(lCount + 1, 1)))
            dSlope2 = .Slope(Array(varX(lCount + 1, 1), varX(lCount + 2, 1)), Array(varY(lCount + 1, 1), varY(lCount + 2, 1)))
            ' If slopes are the same, point in row lCount+1 can be removed
            If Abs(dSlope1 - dSlope2) < EPSILON Then
                If Not rngRemove Is Nothing Then
                    Set rngRemove = Union(rngRemove, .Index(rngData, lCount + 1, 0))
                Else
                    Set rngRemove = .Index(rngData, lCount + 1, 0)
                End If
            End If
        Next lCount
    End With

    ' Mark the cells red for checking
    rngRemove.Cells.Interior.Color = vbRed
    ' Uncomment the below to delete the cells
    'rngRemove.EntireRow.Delete (xlUp)
End Sub

我们的想法是,如果数据是按x坐标排序的,我们只需要保留斜率变化的点.因此,只要斜率在两个连续的对(A,B)和(B,C)中没有变化,就可以去除B,因为它与(A,C)在同一条线上.我们需要仅检查斜率,因为数据是相对于x排序的,因此我们知道x_A< = x_B< = x_C. 对于给定的例子,
输入：

输出：

我希望这有帮助！

点赞