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
|
# $Id: running.R 1012 2006-11-14 22:25:06Z ggorjan $
"running" <- function(X, Y=NULL,
fun=mean,
width=min(length(X), 20),
allow.fewer=FALSE, pad=FALSE,
align=c("right", "center", "left"),
simplify=TRUE,
by, # added a parameter
...)
{
align=match.arg(align)
n <- length(X)
if (align=="left")
{
from <- 1:n
to <- pmin( (1:n)+width-1, n)
}
else if (align=="right")
{
from <- pmax( (1:n)-width+1, 1)
to <- 1:n
}
else #align=="center"
{
from <- pmax((2-width):n,1)
to <- pmin(1:(n+width-1),n)
if(!odd(width)) stop("width must be odd for center alignment")
}
elements <- apply(cbind(from, to), 1, function(x) seq(x[1], x[2]) )
if(is.matrix(elements))
elements <- as.data.frame(elements) # ensure its a list!
names(elements) <- paste(from,to,sep=':')
if(!allow.fewer)
{
len <- sapply(elements, length)
skip <- (len < width)
}
else
{
skip <- 0
}
run.elements <- elements[!skip]
if(!invalid(by))
run.elements <- run.elements[seq(from=1, to=length(run.elements),
by=by)]
if(is.null(Y)) # univariate
{
funct <- function(which,what,fun,...) fun(what[which],...)
if(simplify)
Xvar <- sapply(run.elements, funct, what=X, fun=fun, ...)
else
Xvar <- lapply(run.elements, funct, what=X, fun=fun, ...)
}
else # bivariate
{
funct <- function(which,XX,YY,fun,...) fun(XX[which],YY[which], ...)
if(simplify)
Xvar <- sapply(run.elements, funct, XX=X, YY=Y, fun=fun, ...)
else
Xvar <- lapply(run.elements, funct, XX=X, YY=Y, fun=fun, ...)
}
if(allow.fewer || !pad)
return(Xvar)
if(simplify)
if(is.matrix(Xvar))
{
wholemat <- matrix( new(class(Xvar[1,1]), NA),
ncol=length(to), nrow=nrow(Xvar) )
colnames(wholemat) <- paste(from,to,sep=':')
wholemat[,-skip] <- Xvar
Xvar <- wholemat
}
else
{
wholelist <- rep(new(class(Xvar[1]),NA),length(from))
names(wholelist) <- names(elements)
wholelist[ names(Xvar) ] <- Xvar
Xvar <- wholelist
}
return(Xvar)
}
|
