R中两条曲线之间的插值

Question

我有两条使用近似函数填充相同点数的曲线，对于每条曲线分别对x和y值。 x轴和y轴都是对数的，因此在近似和插值时我会转换回正常的十进制比例。黑色和蓝色线条是原始线条，红色线条插入其间。如您所见，红线不会模仿右侧的弯曲，因为插值是基于每个x和y对最接近的假设来执行的。

有没有办法如何根据两者之间的真实最近点在R中的曲线之间进行插值？也许存在算法？任何事情都会有用，因为我不确定它是如何被称为数学的。

    base="ftp://cdsarc.u-strasbg.fr/pub/cats/J/A+A/508/355/ms/"
    setwd("~/Desktop")
    file1=paste(base,"z001y23_1.60.dat",sep="")
    file2=paste(base,"z001y23_1.70.dat",sep="")

    cols=c("no","age","logL","logTef", "grav","stage")
    ncol <- length(count.fields(file=file1, sep = ","))
    second=read.table(file=file1,fill=T, blank.lines.skip=F, skip=2, header=F, strip.white=T, col.names = paste("V", seq_len(ncol)))
    second$V.6<-second$V.23
    colnames(second) <-cols
    second$logL=as.numeric(second$logL)
    #performing some filtering of data here
    pos1=which(second$stage == "trgb")[1]
    second=second[1:pos1,]

    ncol <- length(count.fields(file=file2, sep = ","))
    first=read.table(file=file2,fill=T, blank.lines.skip=F, skip=2, header=F, strip.white=T, col.names = paste("V", seq_len(ncol)))
    first$V.6<-first$V.23
    colnames(first) <-cols
    #performing some filtering of data here
    pos2=which(first$stage == "trgb")[1]
    first=first[1:pos2,]

    #plotting data
    len=max(c(min(first[[4]]),min(second[[4]])))
    first=first[first[[4]]>len,]
    second=second[second[[4]]>len,]

    plot(second[[4]],second[[3]],t="l",xlim=rev(range(second[[4]])),xlab="x",ylab="y")
    lines(first[[4]],first[[3]],t="l",col="blue")
    n=max(c(length(second[[4]]),length(first[[4]])))
    #approximating missing points
    xf1 <- approx(10^second[[4]],n=n)
    yf1 <- approx(10^second[[3]],n=n)

    xf2 <- approx(10^first[[4]],n=n)
    yf2 <- approx(10^first[[3]],n=n)

    #calculating interpolated line
    ratio=2
    s1<-log10((xf1$y-xf2$y)/ratio+xf2$y)
    s2<-log10((yf1$y-yf2$y)/ratio+yf2$y)
    lines(s1,s2, col ="red")

Answer 1

虽然不是最终的答案，这里有一些改编自我之前为流媒体迁移所做的事情。请注意，这些通常不会自行穿越，因此您的里程可能会有所不同整个想法是计算曲率并使用dynamic time warping来匹配极值。

大致可以这样总结：

1. 参数化两条曲线，因此L1和L2是表示从曲线开始到相关指数的长度的向量。
2. 使用L1和L2计算smooth.spline xsp1，ysp1，xsp2，ysp2，每条曲线的x和y。注意平滑参数，因为曲线有时看起来很清晰。
3. Explicitly为每条平滑线获取signed curvature
4. 使用dtw匹配每条平滑线的曲率峰值
5. 使用dtw返回的索引来建立曲线之间的映射
6. ...
7. PROFIT !!!

请注意，dtw不会创造奇迹，并且需要进行一些实验。

P.S。为了节省您的时间，我尝试直接在x＆amp;上使用dtw没有曲率的y，但它并没有变得很好，因为我们想要同时映射两个坐标。

修改

library(dtw)
df1 <- data.frame(x=first[[4]], y=first[[3]])
df2 <- data.frame(x=second[[4]], y=second[[3]])
measure <- function(df)
  within(df, m <- c(0, cumsum(diff(x)^2 + diff(y)^2)))
df1 <- measure(df1)
df2 <- measure(df2)

curvify <- function(df) {
  xsp <- with(df, smooth.spline(m, x))
  ysp <- with(df, smooth.spline(m, y))
  xx <- predict(xsp, df$m)$y
  yy <- predict(ysp, df$m)$y
  xp <- predict(xsp, df$m, deriv=1)$y
  xpp <- predict(xsp, df$m, deriv=2)$y
  yp <- predict(ysp, df$m, deriv=1)$y
  ypp <- predict(ysp, df$m, deriv=2)$y
  # http://en.wikipedia.org/wiki/Curvature#Signed_curvature
  within(df, c <- (xp*ypp - yp*xpp)/(xp^2 + yp^2)^1.5)
}

df1 <- curvify(df1)
df2 <- curvify(df2)

d <- dtw(df1$c, df2$c, keep=TRUE)
# plot(d, type='three')

xx <- ( df1$x[d$index1] + df2$x[d$index2] ) /2
yy <- ( df1$y[d$index1] + df2$y[d$index2] ) /2

lines(xx, yy, col="green")





修改

使用1/2以外的权重进行插值

fr <- 1/3
xx <- df1$x[d$index1] * fr + df2$x[d$index2] * (1-fr)
yy <- df1$y[d$index1] * fr + df2$y[d$index2] * (1-fr)
lines(xx, yy, col="yellow")

fr <- 2/3
xx <- df1$x[d$index1] * fr + df2$x[d$index2] * (1-fr)
yy <- df1$y[d$index1] * fr + df2$y[d$index2] * (1-fr)
lines(xx, yy, col="brown")