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
|
na.spline <- function(object, ...) UseMethod("na.spline")
na.spline.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.spline.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.spline.zooreg <- function(object, ...) {
object. <- structure(object, class = setdiff(class(object), "zooreg"))
as.zooreg(na.spline(object., ...))
}
na.spline.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.spline.vec <- function(x, y, xout = x, ...) {
na <- is.na(y)
if(sum(!na) < 1L) {
## splinefun() 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 <- splinefun(x[!na], y[!na], ...)(xout)
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 <- splinefun(x, seq_along(y), ...)(xout)
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.spline.vec(x., coredata(object.), xout = xout., ...)
} else {
apply(coredata(object.), 2, na.spline.vec, x = x., xout = xout., ...)
}
if (na.rm) {
result <- na.trim(result, is.na = "all", maxgap = maxgap)
}
result
}
na.spline.ts <- function(object, ...) {
as.ts(na.spline(as.zoo(object), ...))
}
|
