Играем в идеальный тетрис: как выровнять и масштабировать две кривые с помощью масштабирования и перевода?

Это вернет расстояния между точками, когда curve1 масштабируется по оси y с коэффициентом «tfac» и перемещается по оси x на величину «s»:

 as.matrix( dist( rbind(as.matrix(curve2), 
                 ( matrix(c(rep(s, 5), rep(1,5)), ncol=2) +   # x-shift matrix
                                       as.matrix(curve1) ) %*% 
                   matrix(c( 1, 0, 0, tfac),ncol=2) ) ) # the y-scaling matrix
                )[ 
                           # better not to use 't' as a variable name
      -(1:5), -(6:11)]  # easier to return the relevant distances when in matrix

Это должно быть несложно поместить в функцию, которую нужно минимизировать:

 dfunc <- function(C1, C2, s, tfac) { sum( .... ) }

Я не совсем уверен, что это вернет ожидаемый результат, поскольку целевая функция, которую вы подразумеваете, может не быть суммой расстояний. Возможно, вам придется обратиться к методам целочисленного программирования. Представление задач Optimization CRAN было бы хорошим местом для поиска этих методов в R. Я полагаю, что альтернативой, если возникает эта проблема, могло бы быть округление значения «s» и масштабирование только до ближайшей степени 2.

dfunc <- function(param, D1=curve1, D2=curve2) { 
           sum( as.matrix(dist( 
                   rbind(as.matrix(D2), 
                         ( matrix(c(rep(param[1], 5), rep(1,5)), ncol=2) + 
                           as.matrix(D1) ) %*% 
                   matrix(c(1,0,0,param[2]),ncol=2) ) ) )[-(1:5), -(6:11)])}
optim(c(1,1), dfunc)
#$par
$[1] 3.3733977 0.2243866
# trimmed output

Используя эти значения, получается следующая суперпозиция:

Поэтому я мог бы попробовать s = 3, tfac = 0,25. (Оглядываясь назад, я вижу, что поменял роли t и s с того, о чем вы просили. Извините.)

Хорошо, вот попытка решения.

Основной трюк заключается в следующем: мы растеризуем две кривые, а затем можем провести сравнение кривых для каждого элемента мозаичного изображения. По крайней мере, это кажется довольно разумным способом сравнения суперпозиции кривых. Чтобы побудить оптимизатор приблизиться к кривой, мы также вводим потерю, которая штрафует кривые, расположенные слишком далеко друг от друга.

Нет никаких гарантий, что это сработает для более сложных кривых и преобразований, но, по крайней мере, это идея.

 curve2<-data.frame(x=c(4,5,5,6,6,7),
                    y=c(2,2,1,1,2,3))
 fillin <- function(ax, ay, bx, by, scaling= 10, steps= 100) floor(cbind(seq(from = ax, to = bx, len = steps), seq(from = ay, to = by, len = steps)) * scaling)
 Bmat <- matrix(0, 100, 100)
 for (i in 2:nrow(curve2)){
 Bmat[fillin (curve2[i-1,1], curve2[i-1,2], curve2[i,1], curve2[i,2])] =1
 }
 Bmat.orig = Bmat

 Bmat = Bmat.orig
 #construct utility function based on 
 #manhattan distances to closest point?
 shift = function(mat, offset){
 mat0 = array(0, dim = dim(mat)+2)
 mat0[1:nrow(mat) +1+ offset[1] , 1:ncol(mat) + 1+offset[2]] = mat
 return(mat0[1:nrow(mat) + 1, 1:ncol(mat) + 1])
 }

 for (i in 1:100){
 Bm = (Bmat != 0)
 Btmp1 = shift(Bm, c(1,0))
 Btmp2 = shift(Bm, c(-1,0))
 Btmp3 = shift(Bm, c(0,1))
 Btmp4 = shift(Bm, c(0,-1))

 Bmat = Bmat + pmax(Bm ,Btmp1, Btmp2, Btmp3, Btmp4)/i
 }

 Bmat2 = replace(Bmat, Bmat == max(Bmat), max(Bmat) + 10)

 #construct and compare rasterised versions
 getcurve = function(trans = c(0,1),  curve=data.frame(x=c(1,1,2,2,3) ,
                    y=c(9,6,6,3,3) ), Bmat = Bmat2){
 Amat = array(0, dim = dim(Bmat))
 curve[,1] = curve[,1] + trans[1]
 curve[,2] = curve[,2] * trans[2]
 for (i in 2:nrow(curve)){
 fillin (curve[i-1,1], curve[i-1,2], curve[i,1], curve[i,2]) -> ind
 if (min(ind) < 1 || max(ind) > nrow(Bmat)) return( array(-1, dim= dim(Bmat)))
 Amat[ind] =1
 }
 Amat = (Amat - mean(Amat))/sd(as.vector(Amat))
 Amat
 }
 compcurve = function(trans = c(0,1), curve=data.frame(x=c(1,1,2,2,3) ,
                    y=c(9,6,6,3,3) ) , Bmat = Bmat2){
 Amat = getcurve(trans, curve, Bmat)
 -sum(Amat * Bmat)
 }
 #SANN seems to work for this, but is slow. Beware of finite differencing
 # - criterion is non-smooth! 
 optim(c(0,1), compcurve, method = "SANN", Bmat = Bmat2) -> output
 image(Bmat)
 contour(getcurve(output$par), add = T)

Результат:

Может, не так уж и плохо?

Возможно, вам придется подделать особенности растеризации, чтобы поработать над другими проблемами. И вы можете настроить, как выполняется оптимизация.

«Более разумная» альтернатива - заметить, что для оптимального решения, вероятно, будет совпадать хотя бы одна пара вершин. Это может дать вам лучшую стратегию поиска. Преимущество схемы растеризации по сравнению с кривыми с областью между кривыми состоит в том, что она, возможно, более гибкая по отношению к различным преобразованиям и неграфам (в частности, вертикальная линия в вашей первой кривой является проблемой). Вы можете потенциально избежать растеризации с помощью подходящее вычисление, но от одной только мысли об этом у меня заболела голова.

Поскольку мы максимизируем критерий, это метод максимального правдоподобия. Любопытно, но я думаю, что на самом деле невозможно сформулировать этот вопрос как проблему максимального правдоподобия, используя нормальные ошибки, потому что нормальные ошибки подразумевают критерии на основе L2, которые, как известно, не дадут вам точную суперпозиции.