将5阶Bézier曲线拟合到数据集

Question

这是一个稍微具体的问题，所以对R和Bézier曲线的一些了解需要帮助...（谢谢你，如果你这样做的话）。

所以我需要一些关于我的R代码的帮助：我有一系列离散采样的观察结果，我试图通过简单的Bézier回归通过这些点拟合第五阶的LSS曲线。我对6个控制点的位置有一些限制：

• A＆amp; B具有相同的Y轴坐标
• B＆amp; C具有相同的X轴坐标
• C＆amp; D具有相同的Y轴坐标
• D＆amp; E具有相同的X轴坐标
• E＆amp; F具有相同的Y轴坐标
• A位于距离最后一个转折点2点的位置 观察
• 最后一次观察的X轴坐标是 在X轴坐标E和F
之间的某处

喜欢这张图片：

说我有这些数据：

-0.01105 
-0.01118 
-0.01271 
-0.01479
-0.01729
-0.01996
-0.02250
-0.02473
-0.02554
-0.02478
-0.02207
-0.01788
-0.01319
-0.00956

它们具有“曲线”形状，因此Bézier曲线适合：我的代码的结果是这个图像：数据为红色，5阶Bézier及其控制点，其限制为蓝色：

喜欢这张图片：

所以你看到我有某种解决方案，但这就是问题所在： 最右边控制点的X轴位置始终位于最后一个输入数据点的右侧，为了得到合适的拟合，我必须要求t值（在Bézier中t从0变为1） t是输入数据的结束（我的代码中的“限制”变量）。我如何重写它，所以我不必再这样做了，并且t值的水平扩展保持不变，也在输入数据之外？ （考虑到控制点的限制，并最大化与输入数据重叠的曲线部分的拟合）

如果你能提供帮助，请看看这个R代码，任何帮助都是非常感谢和节日快乐！ ps：我在代码中称为exampledata.csv的只是上面的数据。

getT <- function(x){
	# Calculates length from origin of each point in the path.
	# args:
	# 	x : a one dimensional vector
	# Returns:
	# 	out : a vector of distances from the origin, as a percent of end point - start point distance
	
	out <- cumsum(abs(diff(x)))
	out <- c(0, out/ out[length(out)])
	return(out)
}


cost_f <- function(X,Y,K){
	pred <-K%*%X
	c <- Y- pred
	out <- list(loss= as.vector(t(c)%*%c), pred = pred)
	return(out)
}

df <- read.csv('exampledata.csv')
T <- nrow(df)
df['d'] = 1:T


# # identify all turning points:
# turn_point <- c(1)
# for(i in 2:(T-1)){
	# if( ( (df[i,'x'] < df[i-1,'x']) & (df[i,'x'] < df[i+1,'x'])) | ( (df[i,'x'] > df[i-1,'x']) & (df[i,'x'] > df[i+1,'x']))   ){
		# turn_point <- c(turn_point, i)
	# }
	
# }



fit_last_piece <- function(df){
	limit <- .79
	turn_point <- c(1)
	for(i in 2:(T-1)){
		if( ( (df[i,'x'] < df[i-1,'x']) & (df[i,'x'] < df[i+1,'x'])) | ( (df[i,'x'] > df[i-1,'x']) & (df[i,'x'] > df[i+1,'x']))   ){
			turn_point <- c(turn_point, i)
		}
		
	}
	nk <- length(turn_point) # number of turning points
	data <- df[turn_point[nk-1]:nrow(df),]
	end_x <- data$d[1]
	end_y <- data$x[1]
		
	constr_x <- matrix(c(1,0,0,0,0,0,  # remember data is input column to column
							0,1,1,0,0,0,
							0,0,0,1,1,0,
							0,0,0,0,0,1),nrow = 6, ncol = 4)
	constr_y <- matrix(c(1,1,0,0,0,0,
						 0,0,1,1,0,0,
						 0,0,0,0,1,1),nrow = 6, ncol = 3)
	
	M = matrix(c(-1,5,-10,10,-5,1,
				 5,-20,30,-20,5,0,
				 -10,30,-30,10,0,0,
				 10,-20,10,0,0,0,
				 -5,5,0,0,0,0,
				 1,0,0,0,0,0),nrow = 6, ncol = 6)
	
	t_x = getT(data$d)*limit
	T_x = cbind(t_x^5, t_x^4 ,t_x^3, t_x^2, t_x,rep(1,length(t_x)))
	
	in_par <- ( tail(data$d,1)-data$d[1])*c(2/5,4/5,6/5) + data$d[1]   # initial values of the intermediate x levels are at 1/3 and 2/3 midpoints 
	res_x <- optim(par = in_par, fn = function(par){cost_f(c(data$d[1], par[1],par[2], par[3]), data$d, T_x%*%M%*%constr_x)$loss})
	
	
	#res_x <- optimize(f = function(par){cost_f(c(df$d[1],par,df$d[nrow(df)]), df$d, T_x%*%M%*%constr_x)$loss}, interval = c(df$d[1],df$d[nrow(df)]),tol = .Machine$double.eps^0.25)
	optim_x <- c(data$d[1],res_x$par)
	pred_x <- cost_f(optim_x, data$d, T_x%*%M%*%constr_x)$pred
	
	
	t_y = getT(data$x)*limit
	T_y = cbind(t_y^5, t_y^4,t_y^3, t_y^2, t_y,rep(1,length(t_y)))
	in_par <- c()
	res_y <- optim(par = c(data$x[floor(nrow(data)/2)],tail(data$x,1)), fn = function(par){cost_f(c(data$x[1],par[1],par[2]), data$x, T_y%*%M%*%constr_y)$loss})
	optim_y <- c(data$x[1],res_y$par[1],res_y$par[2])
	#pred_y <- cost_f(res_y$par, df$x, T_y%*%M%*%constr_y)$pred
	pred_y <- cost_f(optim_y, data$x, T_y%*%M%*%constr_y)$pred

	t_x_p <- c(t_x,seq(tail(t_x,1),1,length.out = 10))
	T_x_p <- cbind(t_x_p^5, t_x_p^4 ,t_x_p^3, t_x_p^2, t_x_p,rep(1,length(t_x_p)))
	t_y_p <- c(t_y,seq(tail(t_y,1),1,length.out = 10))
	T_y_p <- cbind(t_y_p^5, t_y_p^4 ,t_y_p^3, t_y_p^2, t_y_p,rep(1,length(t_y_p)))
	pred_x <- T_x_p%*%M%*%constr_x%*%optim_x
	pred_y <- T_y_p%*%M%*%constr_y%*%optim_y
# 	this part is new:
	plot(pred_x,pred_y, ylim = c(min(c(data$x, pred_y,res_y$par)), max(c(data$x, pred_y,res_y$par))),col="blue",type="b")
	points(data$d,data$x,col = 'red',type="b")
	points(pred_x[1],pred_y[1],pch=20,col='blue')
	points(res_x$par[1],pred_y[1],pch=20,col='blue')
	points(res_x$par[1],res_y$par[1],pch=20,col='blue')
	points(res_x$par[2],res_y$par[1],pch=20,col='blue')
	points(res_x$par[2],res_y$par[2],pch=20,col='blue')
	points(res_x$par[3],res_y$par[2],pch=20,col='blue')
	segments(pred_x[1],pred_y[1],res_x$par[1],pred_y[1],lty=3,col='blue')
	segments(res_x$par[1],pred_y[1],res_x$par[1],res_y$par[1],lty=3,col='blue')
	segments(res_x$par[1],res_y$par[1],res_x$par[2],res_y$par[1],lty=3,col='blue')
	segments(res_x$par[2],res_y$par[1],res_x$par[2],res_y$par[2],lty=3,col='blue')
	segments(res_x$par[2],res_y$par[2],res_x$par[3],res_y$par[2],lty=3,col='blue')
}

fit_last_piece(df)