1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
na.approx <- function(object, ...) UseMethod("na.approx")
na.approx.zoo <- function(object, x = index(object), xout, ..., na.rm = TRUE, maxgap = Inf, along) {
if (!missing(along)) {
warning("along to be deprecated - use x instead")
if (missing(x)) x <- along
}
missing.xout <- missing(xout) || is.null(xout)
if (is.function(x)) x <- x(index(object))
if (!missing.xout && is.function(xout)) xout <- xout(index(object))
order.by <- if (missing.xout) index(object) else xout
xout <- if (missing.xout) x else xout
if (missing.xout || identical(xout, index(object))) {
result <- object
} else {
object.x <- object
if (!identical(class(x), class(xout))) {
index(object.x) <- as.numeric(x)
xout <- as.numeric(xout)
} else {
index(object.x) <- x
}
objectm <- merge(object.x, zoo(, xout))
if (length(dim(objectm)) == 2) colnames(objectm) <- colnames(object)
result <- window(objectm, index. = xout)
}
result[] <- na.approx.default(object, x = x, xout = xout, na.rm = FALSE, ..., maxgap = maxgap)
if ((!missing(order.by) && !is.null(order.by)) || !missing.xout) {
index(result) <- order.by
}
if (na.rm) {
result <- na.trim(result, is.na = "all", maxgap = maxgap)
}
result
}
na.approx.zooreg <- function(object, ...) {
object. <- structure(object, class = setdiff(class(object), "zooreg"))
as.zooreg(na.approx(object., ...))
}
na.approx.default <- function(object, x = index(object), xout = x, ..., na.rm = TRUE, maxgap = Inf, along) {
if (!missing(along)) {
warning("along to be deprecated - use x instead")
if (missing(x)) x <- along
}
na.approx.vec <- function(x, y, xout = x, ...) {
na <- is.na(y)
if(sum(!na) < 2L) {
## approx() cannot be applied here, hence simply:
yf <- rep.int(NA, length(xout))
mode(yf) <- mode(y)
if(any(!na)) {
if(x[!na] %in% xout) {
yf[xout == x[!na]] <- y[!na]
}
}
return(yf)
}
if(all(!na) && (length(xout) > maxgap) && !all(xout %in% x)) {
## for maxgap to work correctly 'y' has to contain
## actual NAs and be expanded to the full x-index
xf <- sort(unique(c(x, xout)))
yf <- rep.int(NA, length(xf))
yf[MATCH(x, xf)] <- y
x <- xf
y <- yf
}
yf <- approx(x[!na], y[!na], xout, ...)$y
if (maxgap < length(y)) {
## construct a series like y but with only gaps > maxgap
## (actual values don't matter as we only use is.na(ygap) below)
ygap <- .fill_short_gaps(y, seq_along(y), maxgap = maxgap)
## construct y values at 'xout', keeping NAs from ygap
## (using indexing, as approx() does not allow NAs to be propagated)
ix <- approx(x, seq_along(y), xout, ...)$y
yx <- ifelse(is.na(ygap[floor(ix)] + ygap[ceiling(ix)]), NA, yf)
yx
} else {
yf
}
}
if (!identical(length(x), length(index(object)))) {
stop("x and index must have the same length")
}
x. <- as.numeric(x)
if (missing(xout) || is.null(xout)) xout <- x.
xout. <- as.numeric(xout)
object. <- coredata(object)
result <- if (length(dim(object.)) < 2) {
na.approx.vec(x., coredata(object.), xout = xout., ...)
} else {
apply(coredata(object.), 2, na.approx.vec, x = x., xout = xout., ...)
}
if (na.rm) {
result <- na.trim(result, is.na = "all", maxgap = maxgap)
}
result
}
na.approx.ts <- function(object, ...) {
as.ts(na.approx(as.zoo(object), ...))
}
## x = series with gaps
## fill = same series with filled gaps
.fill_short_gaps <- function(x, fill, maxgap) {
if (maxgap <= 0)
return(x)
if (maxgap >= length(x))
return(fill)
naruns <- rle(is.na(x))
naruns$values[naruns$lengths > maxgap] <- FALSE
naok <- inverse.rle(naruns)
x[naok] <- fill[naok]
return(x)
}
|
