R×ts - 等間隔の時間ステップxtsを等間隔の時間シリーズにリサンプリングする

Question

私はRでxts時系列で作業しています。私が持っているもの

： 不等間隔時間ステップでの時系列データセット。 値（以下の例を参照）時間ステップを重複元の値の割合に対応する等間隔の時間ステップで時系列を：私は取得したい何

。

例：このようなオリジナルシリーズ：

      x 
2016-07-01 00:00:00, 0.0 
2016-07-01 00:01:00, 40.0 
2016-07-01 00:02:00, 60.0 
2016-07-01 00:03:00, 60.0 
2016-07-01 00:04:00, 60.0 
2016-07-01 00:05:00, 100.0 
2016-07-01 00:06:00, 157.0 
2016-07-01 00:07:00, 120.0 
2016-07-01 00:08:00, 24.0 
2016-07-01 00:09:00, 0.0 

注：

sample_xts <- as.xts(read.zoo(text=' 
2016-07-01 00:00:20, 0.0 
2016-07-01 00:01:20, 60.0 
2016-07-01 00:01:50, 30.0 
2016-07-01 00:02:30, 40.0 
2016-07-01 00:04:20, 110.0 
2016-07-01 00:05:30, 140.0 
2016-07-01 00:06:00, 97.0 
2016-07-01 00:07:12, 144.0 
2016-07-01 00:08:09, 0.0 
', sep=',', index=1, tz='', format="%Y-%m-%d %H:%M:%S")) 
names(sample_xts) <- c('x') 

が、私はこのようになります等間隔時系列を取得したいのですが

• いくつかの元のタイムステップは新しいタイムステップよりも小さいものの、 他は大きいです。
• xのcolSumは変更されない（すなわち、621）ままである。私が作成に限定されるものではないアプローチを希望

  ：ここ

は、私は（私がやりたいものを説明するのに役立つ場合があります）上記の例を作成するために使用されるスケッチです1分のタイムステップシリーズですが、一般的には任意の固定タイムステップになります。

私はstackoverflowでたくさんのq/aを見て、さまざまなことを試しましたが、成功しませんでした。

ご協力いただければ幸いです！ありがとう。

Answer 1

私はzooを使って書いたコードです - 私はxtsをあまり使わなかったので、同じ機能を適用できるかどうかわかりません。希望が助けてくれる！

機能

次の関数は、元データの各区間について、算出し、所定の間隔（注と重複画分：次のコードの全てにおいて、変数名ta1とta2を参照してください与えられた時間間隔の開始と終了（例えば、あなたが出力として必要な等間隔の各）、元データの（等しくない）区間）の開始と終了を参照してくださいtb1とtb2ながら、：

frac.overlap <- function(ta1,ta2,tb1,tb2){ 
if(tb1 <= ta1 & tb2 >= ta2) { # Interval 2 starts earlier and ends later than interval 1 
    frac <- as.numeric(difftime(ta2,ta1,units="secs"))/as.numeric(difftime(tb2,tb1,units="secs")) 
} else if(tb1 >= ta1 & tb2 <= ta2) { # Interval 2 is fully contained within interval 1 
    frac <- 1 
} else if(tb1 <= ta1 & tb2 >= ta1) { # Interval 2 partly overlaps with interval 1 (starts earlier, ends earlier) 
    frac <- as.numeric(difftime(tb2,ta1,units="secs"))/as.numeric(difftime(tb2,tb1,units="secs")) 
} else if (tb1 <= ta2 & tb2 >= ta2){ # Interval 2 partly overlaps with interval 1 (starts later, ends later) 
    frac <- as.numeric(difftime(ta2,tb1,units="secs"))/as.numeric(difftime(tb2,tb1,units="secs")) 
     } else {        # No overlap 
      frac <- 0 
    } 

    return(frac) 
} 

現在検討間隔 ta1で元のデータセットの重複を記録し、次の機能が決定

からta2：

check.overlap <- function(ta1,ta2,tb1,tb2){ 
ov <- vector("logical",4) 
ov[1] <- (tb1 <= ta1 & tb2 >= ta2) # Interval 2 starts earlier and ends later than interval 1 
ov[2] <- (tb1 >= ta1 & tb2 <= ta2) # Interval 2 is fully contained within interval 1 
ov[3] <- (tb1 <= ta1 & tb2 >= ta1) # Interval 2 partly overlaps with interval 1 (starts earlier, ends earlier) 
ov[4] <- (tb1 <= ta2 & tb2 >= ta2) # Interval 2 partly overlaps with interval 1 (starts later, ends later) 
return(as.logical(sum(ov))) # Gives TRUE if at least one element of ov is TRUE, otherwise FALSE 
} 

（注：これはあなたが提供されているサンプルデータとうまく動作しますが、より大きなデータセットに、I非常に遅いことが判明しました。私はこのコードを書き、定期的なタイムステップで時系列を再サンプリングするので、私は通常、このステップを完了するために一定の間隔を使用します。これは劇的に高速です。

次の関数は、ある区間の再標本化された値を計算するために前の2つを使用します（次の関数のコードを参照してください）

fracres <- function(tstart,interval,input){ 
# tstart: POSIX object 
# interval: length of interval in seconds 
# input: zoo object 

ta1 <- tstart 
ta2 <- tstart + interval 

# First, determine which records of the original data (input) overlap with the current 
# interval, to avoid going through the whole object at every iteration 
ind <- index(input) 
ind1 <- index(lag(input,-1)) 
recs <- which(sapply(1:length(ind),function(x) check.overlap(ta1,ta2,ind[x],ind1[x]))) 
#recs <- which(abs(as.numeric(difftime(ind,ta1,units="secs"))) < 601) 


# For each record overlapping with the current interval, return the fraction of the input data interval contained in the current interval 
if(length(recs) > 0){ 
    fracs <- sapply(1:length(recs), function(x) frac.overlap(ta1,ta2,ind[recs[x]],ind1[recs[x]])) 
    return(sum(coredata(input)[recs]*fracs)) 

} else { 
    return(0) 
} 
} 

（コメントアウトされたラインはオリジナルと新しいタイムステップ間の最大時間差がわかっている場合、関連するレコードを取得する方法を示しています。）

アプリケーション

： ta2から ta1

まずは、zooオブジェクトとしてあなたのサンプルデータを読み込みましょう：あなたのデータセットは、瞬時値が含まれています（「01:20で、xの値が60である」）のような

sample_zoo <- read.zoo(text=' 
2016-07-01 00:00:20, 0.0 
2016-07-01 00:01:20, 60.0 
2016-07-01 00:01:50, 30.0 
2016-07-01 00:02:30, 40.0 
2016-07-01 00:04:20, 110.0 
2016-07-01 00:05:30, 140.0 
2016-07-01 00:06:00, 97.0 
2016-07-01 00:07:12, 144.0 
2016-07-01 00:08:09, 0.0 
', sep=',', index=1, tz='', format="%Y-%m-%d %H:%M:%S") 

はそれが見えます。このコードを合計値として書いたので、タイムスタンプの意味は異なります（「01:20で始まるレコードの値は60です）。これを修正するために、レコードがシフトする必要があります

sample_zoo <- lag(sample_zoo,1) 

その後、我々は所望の解像度に対応するPOSIXctオブジェクトのシーケンスを定義します。

time.out <- seq.POSIXt(from=as.POSIXct("2016-07-01"),to=(as.POSIXct("2016-07-01")+(60*9)),by="1 min") 

私たちは、その後、説明機能fracresを、適用することができます上：

data.out <- sapply(1:length(time.out), function(x) fracres(tstart=time.out[x],interval=60,input=sample_zoo)) 

インデックス及びデータがzooオブジェクトに結合される。

zoo.out <- read.zoo(data.frame(time.out,data.out)) 

そして最後に、時系列は前と反対方向に、1つのステップで再びシフトしている：

zoo.out <- lag(zoo.out,-1) 

2016-07-01 00:01:00 2016-07-01 00:02:00 2016-07-01 00:03:00 2016-07-01 00:04:00 2016-07-01 00:05:00 2016-07-01 00:06:00 2016-07-01 00:07:00 2016-07-01 00:08:00 2016-07-01 00:09:00 
      40     60     60     60     100     157     120     24     0 

Answer 2

は、私はようやくこれで「whileループウェイ」を行くことにしたとしてい以下のソリューションを作成しました。それはうまくいく - 超高速ではありませんが、実行時間は時系列の長さに比例するようです。私は質問に投稿した小さな例と、330,000の観測値を持つソースタイムシリーズと約110,000のタイムステップのデスティネーションシリーズの両方でテストしました。

送信元と送信先の両方に不規則なタイムステップがある可能性があります。 結果の系列の合計は、ソースのものと同じです。

パフォーマンス：速いですが、速くなる可能性が高いと確信しています。私はそれがかなり長いシリーズのためにはるかに速くなければならないRCppのバージョンのための明らかな候補だと思います。今のところこれは私のために行います。RCpp版の作成に至ったときは、ここに投稿します。

パフォーマンス向上のためのご提案があれば投稿してください。

ありがとうございました！

sameEndTime <- function(i,j,src_index,dest_index){ 
    if(src_index[i] == dest_index[j]){ 
    TRUE 
    } else { 
    FALSE 
    } 
} 

wholeSourceStepIsWithinDestStep <- function(i,j,src_index,dest_index){ 
    if(dest_index[j-1] <= src_index[i-1] & src_index[i] <= dest_index[j]){ 
    TRUE 
    } else { 
    FALSE 
    } 
} 

wholeDestStepIsWithinSourceStep <- function(i,j,src_index,dest_index){ 
    if(src_index[i-1] <= dest_index[j-1] & dest_index[j] <= src_index[i]){ 
    TRUE 
    } else { 
    FALSE 
    } 
} 

onlyEndOfSourceStepIsWithinDestStep <- function(i,j,src_index,dest_index){ 
    if(src_index[i-1] < dest_index[j-1] & src_index[i] < dest_index[j] & src_index[i] > dest_index[j-1]){ 
    TRUE 
    } else { 
    FALSE 
    } 
} 

onlyStartOfSourceStepIsWithinDestStep <- function(i,j,src_index,dest_index){ 
    if(src_index[i-1] < dest_index[j] & src_index[i-1] > dest_index[j-1] & src_index[i] > dest_index[j]){ 
    TRUE 
    } else { 
    FALSE 
    } 
} 

resampleToDestTimeSteps <- function(src, dest){ 
    # src and dest are both xts with only one time series each 
    # src is the original series and 
    # dest holds the time steps of the final series 
    # 
    # NB: there is an issue with the very first time step 
    # (gets ignored in this version) 
    # 
    original_names <- names(src) 
    names(src) <- c("value") 
    names(dest) <- c("value") 
    dest$value <- dest$value*0.0 
    dest$value[is.na(dest$value)] <- 0.0 

    dest[1]$value = 0.0 

    for(k in 2:length(src)){ 
    src[k]$value <- src[k]$value/as.numeric(difftime(index(src[k]),index(src[k-1]),units="secs")) 
    } 
    # First value is NA due to lag at this point (we don't want that) 
    src$value[1] = 0.0 

    i = 2 # source timestep counter 
    j = 2 # destination timestep counter 

    src_index = index(src) 
    dest_index = index(dest) 

    src_length = length(src) 
    dest_length = length(dest) 

    # Make sure we start with an overlap 
    if(src_index[2] < dest_index[1]){ 
    while(src_index[i] < dest_index[1]){ 
     i = i + 1 
    } 
    } else if(dest_index[2] < src_index[1]){ 
    while(dest_index[j] < src_index[1]){ 
     j = j + 1 
    } 
    } 

    while(i <= src_length & j <= dest_length){ 
    if(wholeSourceStepIsWithinDestStep(i,j,src_index,dest_index)){ 
     dest[j]$value = dest[j]$value + as.numeric(src[i]$value)*as.numeric(difftime(src_index[i],src_index[i-1],units="secs")) 
     if(sameEndTime(i,j,src_index,dest_index)){ 
     j = j+1 
     } 
     i = i+1 
    } else if(wholeDestStepIsWithinSourceStep(i,j,src_index,dest_index)){ 
     dest[j]$value = dest[j]$value + as.numeric(src[i]$value)*as.numeric(difftime(dest_index[j],dest_index[j-1],units="secs")) 
     if(sameEndTime(i,j,src_index,dest_index)){ 
     i = i+1 
     } 
     j = j+1 
    } else if(onlyEndOfSourceStepIsWithinDestStep(i,j,src_index,dest_index)){ 
     dest[j]$value = dest[j]$value + as.numeric(src[i]$value)*as.numeric(difftime(src_index[i],dest_index[j-1],units="secs")) 
     i = i+1 
    } else if(onlyStartOfSourceStepIsWithinDestStep(i,j,src_index,dest_index)){ 
     diff_time = difftime(dest_index[j],src_index[i-1],units="secs") 
     dest[j]$value = dest[j]$value + as.numeric(src[i]$value)*as.numeric(diff_time) 
     j = j+1 
    } else { 
     print("======================================================") 
     print(paste0("i=",i,", j=",j)) 
     print(paste0("src_index[i] =",src_index[i])) 
     print(paste0("dest_index[j] =",dest_index[j])) 
     print(" ") 
     print(paste0("src_index[i-1] =",src_index[i-1])) 
     print(paste0("dest_index[j-1]=",dest_index[j-1])) 
     print("======================================================") 
     stop("This should never happen.") 
    } 
    } 
    names(dest) <- original_names 
    return(dest) 
}