R：不同日期的柵格圖層之間的線性外推

Question

已經有一個thread處理不同年份的柵格圖層之間的插值（2006,2008,2010,2012）。現在，我試圖線性外推至2020年從Hmisc包通過@Ram納拉辛漢和approxExtrap建議的方法：

library(raster) 
library(Hmisc) 

df <- data.frame("2006" = 1:9, "2008" = 3:11, "2010" = 5:13, "2012"=7:15) 

#transpose since we want time to be the first col, and the values to be columns 
new <- data.frame(t(df)) 
times <- seq(2006, 2012, by=2) 
new <- cbind(times, new) 

# Now, apply Linear Extrapolate for each layer of the raster 
approxExtrap(new, xout=c(2006:2012), rule = 2) 

而是獲得這樣的事：

# times X1 X2 X3 X4 X5 X6 X7 X8 X9 
#1 2006 1 2 3 4 5 6 7 8 9 
#2 2007 2 3 4 5 6 7 8 9 10 
#3 2008 3 4 5 6 7 8 9 10 11 
#4 2009 4 5 6 7 8 9 10 11 12 
#5 2010 5 6 7 8 9 10 11 12 13 
#6 2011 6 7 8 9 10 11 12 13 14 
#7 2012 7 8 9 10 11 12 13 14 15 
#8 2013 8 9 10 11 12 13 14 15 16 
#9 2014 9 10 11 12 13 14 15 16 17 
#10 2015 10 11 12 13 14 15 16 17 18 
#11 2016 11 12 13 14 15 16 17 18 19 
#12 2017 12 13 14 15 16 17 18 19 20 
#13 2018 13 14 15 16 17 18 19 20 21 
#14 2019 14 15 16 17 18 19 20 21 22 
#15 2020 15 16 17 18 19 20 21 22 23 

我得到這個：

$x 
[1] 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 

$y 
[1] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 

這既是approxTime和approxExtrap基於approxfun相當混亂。

Answer 1

我找到了一種方法來使這項工作，雖然它似乎不是最優雅的方式來做到這一點。基本思想是首先使用approxTime進行線性插值，然後使用lm將線性模型擬合到時間序列，並通過使用predict和外推的最後一年來推斷。再次使用approxTime填充第一次插值的最後一年和結束年之間的數據差距。

注意：第一次線性插值並不是真的必要，但我不知道當您使用更復雜的數據時是否有任何區別。

library(raster) 
library(Hmisc) 
library(simecol) 


df <- data.frame("2006" = 1:9, "2008" = 3:11, "2010" = 5:13, "2012"=7:15) 

#transpose since we want time to be the first col, and the values to be columns 
new <- data.frame(t(df)) 
times <- seq(2006, 2012, by=2) 
new <- cbind(times, new) 



# Now, apply Linear Interpolate for each layer of the raster 
intp<-approxTime(new, 2006:2012, rule = 2) 

#Extract the years from the data.frame 
tm<-intp[,1] 

#Define a function for a linear model using lm 
lm.func<-function(i) {lm(i ~ tm)} 

#Define a new data.frame without the years from intp 
intp.new<-intp[,-1] 

#Creates a list of the lm coefficients for each column of intp.new 
lm.list<-apply(intp.new, MARGIN=2, FUN=lm.func) 

#Create a data.frame of the final year of your extrapolation; keep the name of tm data.frame 
new.pred<-data.frame(tm = 2020) 

#Make predictions for the final year for each element of lm.list 
pred.points<-lapply(lm.frame, predict, new.pred) 

#unlist the predicted points 
fintime<-matrix(unlist(pred.points)) 

#Add the final year to the fintime matrix and transpond it 
fintime.new<-t(rbind(2020,fintime)) 

#Convert the intp data.frame into a matrix 
intp.ma<-as.matrix(intp) 

#Append fintime.new to intp.ma 
intp.wt<-as.data.frame(rbind(intp.ma,fintime.new)) 

#Perform an linear interpolation with approxTime again 
approxTime(intp.wt, 2006:2020, rule = 2) 


times X1 X2 X3 X4 X5 X6 X7 X8 X9 
1 2006 1 2 3 4 5 6 7 8 9 
2 2007 2 3 4 5 6 7 8 9 10 
3 2008 3 4 5 6 7 8 9 10 11 
4 2009 4 5 6 7 8 9 10 11 12 
5 2010 5 6 7 8 9 10 11 12 13 
6 2011 6 7 8 9 10 11 12 13 14 
7 2012 7 8 9 10 11 12 13 14 15 
8 2013 8 9 10 11 12 13 14 15 16 
9 2014 9 10 11 12 13 14 15 16 17 
10 2015 10 11 12 13 14 15 16 17 18 
11 2016 11 12 13 14 15 16 17 18 19 
12 2017 12 13 14 15 16 17 18 19 20 
13 2018 13 14 15 16 17 18 19 20 21 
14 2019 14 15 16 17 18 19 20 21 22 
15 2020 15 16 17 18 19 20 21 22 23