插值和推断数据框中的缺失列

Question

我有一个数据框，其中包含每 4 或 5 年的数据。我希望插入数据框以外的年份数据，并对数据框两端的列进行外插数据。

我已经能够使用下面的代码执行插值。唯一的问题是中间的列被重复并且必须删除一个副本。有没有更有效的插值方法？我也不确定如何攻击外推。实际数据集包含 12 年（列）的可用数据。

感谢您的任何建议。

my.data <- read.table(text = '
    y1980  y1985  y1990
     0.10   0.20   0.40
     1.00   2.00   4.00
    10.00  20.00  40.00
', header = TRUE, na.string='NA', stringsAsFactors=FALSE)

desired.result <- read.table(text = '
    y1978 y1979 y1980 y1981 y1982 y1983 y1984 y1985 y1986 y1987 y1988 y1989 y1990 y1991 y1992
     0.06  0.08  0.10  0.12  0.14  0.16  0.18  0.20  0.24  0.28  0.32  0.36  0.40  0.44  0.48
     0.60  0.80  1.0   1.2   1.4   1.6   1.8   2.0   2.4   2.8   3.2   3.6   4.0   4.4   4.8
     6     8    10    12    14    16    18    20    24    28    32    36    40    44    48
', header = TRUE, na.string='NA', stringsAsFactors=FALSE)
desired.result

# reshape data to form two columns
new.data  <- reshape(my.data, direction="long", 
                     varying = list(seq(1,(ncol(my.data)-1),1), seq(2,(ncol(my.data)-0),1)), 
                     v.names=c("v1", "v2"))

# interpolate every row
interpol  <- t(apply(new.data[,2:3], 1, function(x) approx(x, n = 6)$y))
new.data2 <- data.frame(time = new.data$time, interpol, id = new.data$id)

# reform row:column structure 
my.data2  <- reshape(new.data2, idvar="id", timevar = "time", direction = "wide")

# middle columns are repeated and must be removed
my.data3  <- my.data2[, !names(my.data2) %in% c("X1.2")]
my.data3

    id X1.1  X2.1  X3.1  X4.1  X5.1 X6.1  X2.2  X3.2  X4.2  X5.2 X6.2
1.1  1  0.1  0.12  0.14  0.16  0.18  0.2  0.24  0.28  0.32  0.36  0.4
2.1  2  1.0  1.20  1.40  1.60  1.80  2.0  2.40  2.80  3.20  3.60  4.0
3.1  3 10.0 12.00 14.00 16.00 18.00 20.0 24.00 28.00 32.00 36.00 40.0

一种无效的插值替代方法：

sapply( seq(1, (ncol(my.data)-1), 1), function(i) {approx(c(my.data[,i], my.data[,i+1]), n = 6)$y } )

Answer 1

这是另一种表述。

首先是一个有用的函数：

tvseq <- function(...)t(Vectorize(seq.default)(...))

现在进行插值：

years <- as.numeric(gsub("y","",names(my.data)))

d <- diff(years)

L <- lapply(seq(d), function(i) tvseq(from=my.data[,i], to=my.data[,i+1], length.out=d[i]+1)[,-1])

result <- cbind(my.data[,1], do.call(cbind, L))
colnames(result) <- paste0("y",min(years):max(years))

结果：

> result
     y1980 y1981 y1982 y1983 y1984 y1985 y1986 y1987 y1988 y1989 y1990
[1,]   0.1  0.12  0.14  0.16  0.18   0.2  0.24  0.28  0.32  0.36   0.4
[2,]   1.0  1.20  1.40  1.60  1.80   2.0  2.40  2.80  3.20  3.60   4.0
[3,]  10.0 12.00 14.00 16.00 18.00  20.0 24.00 28.00 32.00 36.00  40.0

要添加外推，请使用：

ylow <- 1978:(min(years)-1)
low <- tvseq(to=result[,1], by=result[,2]-result[,1], length.out=length(ylow)+1)[,1:length(ylow)]
colnames(low) <- paste0("y",ylow)

yhigh <- (max(years)+1):1992
high <- tvseq(from=result[,ncol(result)], by=result[,ncol(result)]-result[,ncol(result)-1], length.out=length(yhigh)+1)[,-1]
colnames(high) <- paste0("y",yhigh)

cbind(low, result, high)

结果：

     y1978 y1979 y1980 y1981 y1982 y1983 y1984 y1985 y1986 y1987 y1988 y1989 y1990 y1991 y1992
[1,]  0.06  0.08   0.1  0.12  0.14  0.16  0.18   0.2  0.24  0.28  0.32  0.36   0.4  0.44  0.48
[2,]  0.60  0.80   1.0  1.20  1.40  1.60  1.80   2.0  2.40  2.80  3.20  3.60   4.0  4.40  4.80
[3,]  6.00  8.00  10.0 12.00 14.00 16.00 18.00  20.0 24.00 28.00 32.00 36.00  40.0 44.00 48.00

Answer 2

内插和外推的替代方法：

library(zoo)
df <- data.frame(t(my.data))
df$yr <- as.numeric(substring(rownames(df), first = 2))
z1 <- zoo(df, order.by = df$yr, frequency = 1)
t1 <- as.ts(x = z1)
t2 <- na.approx(t1)
future <- apply(t2, 2, function(x) tail(x, 1) + diff(tail(x, 2)) * 1:2)
past <- apply(t2, 2, function(x) head(x, 1) - diff(head(x, 2)) * 1:2)
t3 <- rbind(past, t2, future)
t3 <- t3[order(t3[ , "yr"]), ]
t4 <- t(t3)[1:3, ]
colnames(t4) <- paste0("y", t3[ , "yr"])
t4