1

各曲線のx値とy値の両方について、近似関数を使用して塗りつぶされた同じ数の点の2つの曲線があります。x 軸と y 軸の値は両方とも対数であるため、近似と補間を行うときに通常の 10 進数に変換し直します。黒と青の線は元の線で、赤の線はその間を補間したものです。ご覧のとおり、赤い線は右側の曲がりを模倣していません。これは、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")

ここに画像の説明を入力

4

1 に答える 1

3

究極の答えではありませんが、これは、ストリーム チャネルの移行のために少し前に行ったことから改作したものです。これらは通常自己横断ではないため、走行距離が異なる場合があることに注意してください。全体的なアイデアは、曲率を計算し、ダイナミック タイム ワーピングを使用して極値に一致させることです。

ざっくりまとめると以下のようになります。

  1. 両方の曲線をパラメータ化して、L1 と L2 が曲線の始まりから問題のインデックスまでの長さを表すベクトルになるようにします。
  2. smooth.spline各曲線の x と y の L1 と L2 を使用して、xsp1、ysp1、xsp2、ysp2 を計算します。カーブがシャープに見える場合があるため、スムージング パラメータに注意してください。
  3. 平滑化された各線の符号付き曲率を明示的に取得します
  4. dtw を使用して、平滑化された各線の曲率のピークを一致させます
  5. dtw によって返されたインデックスを使用して、曲線間のマッピングを確立します
  6. ...
  7. 利益！！！

dtw は奇跡を起こすわけではなく、実験が必要になることに注意してください。

PS 時間を節約するために、曲率なしで x と y に直接 dtw を使用しようとしましたが、両方の座標を同時にマッピングする必要があるため、うまくいきませんでした。

編集

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")
于 2014-06-13T01:59:51.610 に答える