Ответ 1
Я сомневаюсь, что это возможно без итерации, потому что смещение некоторых точек от ближайших соседей слишком близко может привести к тому, что перемещенные точки будут ближе к другим соседям. Вот одно решение, которое только изменяет те значения, которые необходимы для достижения решения, и перемещает их на минимальное расстояние, чтобы обеспечить минимальный разрыв эпсилона.
Он использует функцию, которая назначает силу каждой точке в зависимости от того, нужно ли ее перемещать от ближайшего соседа. Направление (знак) силы указывает, нужно ли нам увеличивать или уменьшать значение этой точки. Точки, которые зажаты между соседними соседями, не двигаются, но их внешние соседи отодвигаются от центральной точки (это поведение позволяет как можно меньше как можно меньше). Сила, назначенная конечным точкам, всегда равна нулю, потому что мы не хотим, чтобы общий диапазон х изменялся
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)
}
Далее, нам нужна функция для переключения точек, в зависимости от силы, действующей на них. Положительные силы заставляют их двигаться на эпсилон выше, чем предыдущая точка. Отрицательные силы сдвигают их вниз.
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), где вектор, переданный функции, имеет длину & lt; 3
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