编辑数组以确保严格增加值

Question

考虑一个在min 和max 之间有界的排序向量x。下面是x 的示例，其中min 可以是0，max 可以是12：

x = c(0.012, 1, exp(1), exp(1)+1e-55, exp(1)+1e-10,
       exp(1)+1e-3, 3.3, 3.33333, 3.333333333333333, 3+1/3, 5, 5, 10, 12)

5 和 5 以及 exp(1) 和 exp(1)+10^(-55) 具有完全相同的值（达到浮点数的精度级别）。其他一些条目差异很大，而另一些条目差异很小。我想考虑一个近似相等测试

ApproxEqual = function(a,b) abs(a-b) < epsilon

，例如 epsilon 可以是 1e-5。

目标

我想“尽可能少”地修改变量x 的值，以确保x 中没有两个值“近似相等”并且x 仍然在min 和@ 之间987654341@.

我很高兴让您决定“尽可能少”的真正含义。例如，可以最小化原始x 与预期变量输出之间的平方偏差总和。

示例 1

x_input = c(5, 5.1, 5.1, 5.1, 5.2)
min=1
max=100

x_output = c(5, 5.1-epsilon, 5.1, 5.1+epsilon, 5.2)

示例 2

x_input = c(2,2,2,3,3)
min=2
max=3

x_output = c(2, 2+epsilon, 2+2*epsilon, 2+3*epsilon, 3-epsilon,3)

当然，在上述情况下，如果(3-epsilon) - (2+3*epsilon) < epsilon 是TRUE，那么函数应该抛出错误，因为问题没有解决方案。

旁注

如果解决方案非常高效，我会很高兴。例如，答案可以使用Rcpp。

Answer 1

假设这些值按升序排序，使用两个 for 循环似乎最容易做到这一点。第一个 for 循环观察每个数字，第二个（内部）for 循环与每个数字之前的所有数字进行比较。如果 ApproxEqual 为真，则在内部 for 循环中将 1e-5 添加到外部 for 循环解析的值。

下面的代码可以解决问题：

x = c(5, 5.1, 5.1, 5.1, 5.2)

epsilon <-1e-5
ApproxEqual = function(a,b) abs(a-b) < epsilon

for (i in 1:length(x)){
  if (i>1){
    for (j in 1:(i-1)){
      if (ApproxEqual(x[i],x[j])){
        x[i]=x[i]+epsilon
      }
    }
  }
}

print(x)

这给了

> print(x)
[1] 5.00000 5.10000 5.10001 5.10002 5.20000

Answer 2

• 在不修改最小值或最大值的情况下，并不总是可以修改变量的值以确保没有两个值近似相等并且仍然在最小值和最大值之间。例如。 min=0，max=epsilon/2。

• 您可能会反复查找最近的邻居并更改其值（如果需要且可能的话）以使它们不近似相等。 搜索最近邻的算法是众所周知的。 https://en.wikipedia.org/wiki/Nearest_neighbor_search

Answer 3

我怀疑在不迭代的情况下这是可能的，因为将一些点从太近的邻居中移开可能会导致移动的点聚集在更靠近其他邻居的地方。这是一种解决方案，它仅更改获得解决方案所需的那些值，并将它们移动尽可能小的距离，以确保 epsilon 的最小间隙。

它使用一个函数来为每个点分配一个力，这取决于我们是否需要将它从太近的邻居移开。力的方向（符号）表明我们是否需要增加或减少该点的值。夹在其他太近的邻居之间的点不会移动，但它们的外部邻居都从中心点移开（这种行为是尽可能少地移动点）。分配给端点的力始终为零，因为我们不希望 x 的整体范围发生变化

force <- function(x, epsilon){
 c(0, sapply(2:(length(x)-1), function(i){ (x[i] < (x[i-1]+epsilon)) - (x[i] > (x[i+1]-epsilon)) }), 0)
}

接下来，我们需要一个函数来移动点，这取决于作用在它们上的力。积极的力量使他们移动到比前一点更高的epsilon。负面的力量使它们向下移动。

move <- function(x, epsilon, f){
  x[which(f==-1)] <- x[which(f==-1)+1] - epsilon 
  x[which(f==1)]  <- x[which(f==1)-1] + epsilon
  # Next line deals with boundary condition, and prevents points from bunching up at the edges of the range
  # I doubt this is necessary, but included out of abundance of caution. Could try deleting this line if performance is an issue.
  x <- sapply(1:(length(x)), function(i){x[i] <- max(x[i], head(x,1)+(i-1)*epsilon); x[i] <- min(x[i], tail(x,1)-(length(x)-i)*epsilon)})
  x
}

最后，函数separate用于迭代计算力和移动点，直到找到解决方案。它还在迭代之前检查几个边缘情况。

separate <- function(x,epsilon) {
  if (epsilon > (range(x)[2] - range(x)[1]) / (length(x) - 1)) stop("no solution possible")
  if (!(all(diff(x)>=0))) stop ("vector must be sorted, ascending")

  initial.x <- x
  solved <- FALSE

  ##################################
  # A couple of edge cases to catch
  ##################################
  # 1. catch cases when vector length < 3 (nothing to do, as there are no points to move)
  if (length(x)<3) solved <- TRUE
  # 2. catch cases where initial vector has values too close to the boundaries 
  x <- sapply(1:(length(x)), function(i){
    x[i] <- max(x[i], head(x,1)+(i-1)*epsilon)
    x[i] <- min(x[i], tail(x,1)-(length(x)-i)*epsilon)
  })

  # Now iterate to find solution
  it <- 0
  while (!solved) {
    it <-  it+1
    f <- force(x, epsilon)
    if (sum(abs(f)) == 0) solved <- TRUE
    else x <- move(x, epsilon, f)
  }
  list(xhat=x, iterations=it, SSR=sum(abs(x-initial.x)^2))
}

在 OP 提供的示例上对此进行测试：

x = c(0.012, 1, exp(1), exp(1)+1e-55, exp(1)+1e-10, exp(1)+1e-3, 3.3, 3.33333, 3.333333333333333, 3+1/3, 5, 5, 10, 12)
epsilon <- 1e-5

separate(x, epsilon)
# $xhat
# [1]  0.012000  1.000000  2.718272  2.718282  2.718292  2.719282  3.300000  3.333323  3.333333  3.333343
# [11]  4.999990  5.000000 10.000000 12.000000
#
# $iterations
# [1] 2
#
# $SSR
# [1] 4.444424e-10

编辑 1

在函数separate 中添加了行以响应评论以捕捉一些极端情况 -

A) 传递给函数的向量长度

separate(c(0,1), 1e-5)
# $xhat
# [1] 0 1
# 
# $iterations
# [1] 0
# 
# $SSR
# [1] 0

B) 传递的向量在边界处有多个值

separate(c(0,0,0,1), 1e-5)
# [1] "it = 1, SSR = 5e-10"
# $xhat
# [1] 0e+00 1e-05 2e-05 1e+00
# 
# $iterations
# [1] 1
#
# $SSR
# [1] 5e-10

Answer 4

这是一个有趣的挑战，我想我已经找到了解决方案。 它有点丑陋和令人费解，可以做一些精简，但它似乎返回了 Remi 的要求。

library(magrittr)

xin <- c(0.012, 1, exp(1), exp(1)+10^(-55), exp(1)+10^(-10),
    exp(1)+10^(-3), 3.3, 3.33333, 3.333333333333333, 3+1/3, 5, 5, 10, 12)

tiebreaker <- function(x, t=3) {
    dif <- diff(x) %>% round(t)
    x[dif==0] <- x[dif==0] + 
        seq(-10^-t, -10^-(t+0.99), 
        length.out=length(x[dif==0])) %>% sort
    x
}

xout <- tiebreaker(xin)

diff(xin) > 0.0001
# TRUE TRUE FALSE FALSE TRUE TRUE TRUE FALSE FALSE TRUE FALSE TRUE TRUE

diff(xout) > 0.0001  #it makes close matches less close
# TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE

xin == xout  #but leaves already less close matches as they were
# TRUE TRUE FALSE FALSE TRUE TRUE TRUE FALSE FALSE TRUE FALSE TRUE TRUE TRUE

编辑：我把它包装成一个简单的函数。 tr 设置被认为是接近匹配的阈值，以小数点为单位。