2016-08-05 71 views
4

我正在R與xts時間系列工作。R xts - 重新採樣不等時間步xts到等距時間序列

我有什麼: 時間序列數據集具有不等間隔時間步驟。

我想獲得: 用其值對應於重疊的時間步驟中的原始值的比例相等間隔的時間步驟的時間序列(見下例)。

例子:採用原始系列這樣的:

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 
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 

注:

  • 某些原始時間步長小於新時間步長,而 其他人更大。
  • x的colSums保持不變(即621)。

這裏是我用來創建上面的例子中(可能有助於說明我想要做什麼)的草圖: illustration of resampling

我想這不限於創建方法一個1分鐘的時間步長系列,但通常是任何固定的時間步長。

我看了很多q/a在stackoverflow上,並嘗試了很多不同的東西,但沒有成功。

任何幫助將不勝感激!謝謝。

回答

1

下面是我用zoo寫的一些代碼 - 我還沒有使用xts,所以我不知道是否可以應用相同的函數。希望有所幫助!

功能

下面的函數來計算,對於原始數據中的每個間隔,即以給定的時間間隔(注重疊分數:在下面所有的代碼,變量名ta1ta2指一個給定的時間間隔的開始和結束(例如在每次需要作爲輸出相等的間隔),而tb1tb2指原始數據的(不相等)的間隔)的開始和結束:

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 
} 

(注:這工作得很好,您所提供的樣本數據,但在更大的數據集,我發現它過於緩慢。由於我編寫的這段代碼是用一個固定的時間步重新採樣時間序列,所以我通常使用一個固定的時間間隔來完成這個步驟,這個過程要快得多。可能很容易修改代碼(查看下一個函數的代碼),以便根據原始數據的間隔加快此步驟。)

下一個函數使用前兩個函數來計算間隔的重採樣值ta1 - ta2

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) 
} 
} 

(被註釋掉的行顯示如何獲取相關記錄,如果原來的和新的時間步長之間的最大時間差是已知的)

應用

首先,讓我們在您的樣本數據讀取爲zoo對象:

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:20x值60」)。由於我爲彙總值編寫了此代碼,因此時間戳的含義不同(「起始於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)) 

最後,時間序列又一步像以前那樣移動,向相反的方向:

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 
+0

Thanks @ m.chips!最後在我的實時系列中嘗試了這一點。完美的作品,但是,是的,正如你所指出的那樣,即使是很短的系列,它也會變得「過於緩慢」。看起來,執行時間與系列的長度不成比例地增長 - 按指數或2^N。我的系列有30萬到1萬。觀察靈感來自你的算法,我決定嘗試別的。在下面的帖子中回答問題。 –

0

我終於決定去了「而循環路」這個和有下面創建瞭解決方案。它運行良好 - 速度不是很快,但執行時間似乎與時間序列的長度成正比。我用我在問題中發佈的一個小例子對它進行了測試,其源代碼時間序列具有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) 
}