|
0 |
.packageName <- "gtools"
|
|
1 |
# $Id: RSCompat.S,v 1.9 2005/06/09 14:20:28 nj7w Exp $
|
|
2 |
#
|
|
3 |
# $Log: RSCompat.S,v $
|
|
4 |
# Revision 1.9 2005/06/09 14:20:28 nj7w
|
|
5 |
# Updating the version number, and various help files to synchronize splitting of gregmisc bundle in 4 individual components.
|
|
6 |
#
|
|
7 |
# Revision 1.1.1.1 2005/05/25 22:17:28 nj7w
|
|
8 |
# Initial submision as individual package
|
|
9 |
#
|
|
10 |
# Revision 1.8 2003/04/04 13:58:59 warnes
|
|
11 |
#
|
|
12 |
# - Replace 'T' with 'TRUE'
|
|
13 |
#
|
|
14 |
# Revision 1.7 2003/03/07 15:48:35 warnes
|
|
15 |
#
|
|
16 |
# - Minor changes to code to allow the package to be provided as an
|
|
17 |
# S-Plus chapter.
|
|
18 |
#
|
|
19 |
# Revision 1.6 2003/01/02 15:42:00 warnes
|
|
20 |
# - Add nlevels function.
|
|
21 |
#
|
|
22 |
# Revision 1.5 2002/03/20 03:44:32 warneg
|
|
23 |
# - Added definition of is.R function.
|
|
24 |
#
|
|
25 |
# - Added boxplot.formula
|
|
26 |
#
|
|
27 |
# Revision 1.4 2002/02/05 02:20:07 warneg
|
|
28 |
#
|
|
29 |
# - Fix typo that caused code meant to run only under S-Plus to run
|
|
30 |
# under R, causing problems.
|
|
31 |
#
|
|
32 |
# Revision 1.3 2001/12/19 22:45:44 warneg
|
|
33 |
# - Added code for %in%.
|
|
34 |
#
|
|
35 |
# Revision 1.2 2001/09/18 14:15:44 warneg
|
|
36 |
#
|
|
37 |
# Release 0.3.2
|
|
38 |
#
|
|
39 |
# Revision 1.1 2001/09/01 19:19:13 warneg
|
|
40 |
#
|
|
41 |
# Initial checkin.
|
|
42 |
#
|
|
43 |
#
|
|
44 |
# Code necessary for contrast.lm, boxplot.n to work in S-Plus
|
|
45 |
|
|
46 |
if(!exists("is.R") || !is.R() )
|
|
47 |
{
|
|
48 |
is.R <- function() FALSE
|
|
49 |
|
|
50 |
getOption <- function(...) options(...)
|
|
51 |
|
|
52 |
if(!exists("parent.frame")) parent.frame <- sys.parent
|
|
53 |
|
|
54 |
colnames <- function (x, do.NULL = TRUE, prefix = "col")
|
|
55 |
{
|
|
56 |
dn <- dimnames(x)
|
|
57 |
if (!is.null(dn[[2]]))
|
|
58 |
dn[[2]]
|
|
59 |
else {
|
|
60 |
if (do.NULL)
|
|
61 |
NULL
|
|
62 |
else paste(prefix, seq(length = NCOL(x)), sep = "")
|
|
63 |
}
|
|
64 |
}
|
|
65 |
|
|
66 |
rownames <- function (x, do.NULL = TRUE, prefix = "row")
|
|
67 |
{
|
|
68 |
dn <- dimnames(x)
|
|
69 |
if (!is.null(dn[[1]]))
|
|
70 |
dn[[1]]
|
|
71 |
else {
|
|
72 |
if (do.NULL)
|
|
73 |
NULL
|
|
74 |
else paste(prefix, seq(length = NROW(x)), sep = "")
|
|
75 |
}
|
|
76 |
}
|
|
77 |
|
|
78 |
"rownames<-" <- function (x, value)
|
|
79 |
{
|
|
80 |
dn <- dimnames(x)
|
|
81 |
ndn <- names(dn)
|
|
82 |
dn <- list(value, if (!is.null(dn)) dn[[2]])
|
|
83 |
names(dn) <- ndn
|
|
84 |
dimnames(x) <- dn
|
|
85 |
x
|
|
86 |
}
|
|
87 |
|
|
88 |
"colnames<-" <- function (x, value)
|
|
89 |
{
|
|
90 |
dn <- dimnames(x)
|
|
91 |
ndn <- names(dn)
|
|
92 |
dn <- list(if (!is.null(dn)) dn[[1]], value)
|
|
93 |
names(dn) <- ndn
|
|
94 |
dimnames(x) <- dn
|
|
95 |
x
|
|
96 |
}
|
|
97 |
|
|
98 |
# from the MASS library by Venables & Ripley
|
|
99 |
ginv <- function (X, tol = sqrt(.Machine$double.eps))
|
|
100 |
{
|
|
101 |
if (length(dim(X)) > 2 || !(is.numeric(X) || is.complex(X)))
|
|
102 |
stop("X must be a numeric or complex matrix")
|
|
103 |
if (!is.matrix(X))
|
|
104 |
X <- as.matrix(X)
|
|
105 |
Xsvd <- svd(X)
|
|
106 |
if (is.complex(X))
|
|
107 |
Xsvd$u <- Conj(Xsvd$u)
|
|
108 |
Positive <- Xsvd$d > max(tol * Xsvd$d[1], 0)
|
|
109 |
if (all(Positive)) Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
|
|
110 |
else if (!any(Positive)) array(0, dim(X)[2:1])
|
|
111 |
else Xsvd$v[, Positive] %*% ((1/Xsvd$d[Positive]) * t(Xsvd$u[, Positive]))
|
|
112 |
}
|
|
113 |
|
|
114 |
|
|
115 |
"format.pval" <-
|
|
116 |
function (pv, digits = max(1, getOption("digits") - 2),
|
|
117 |
eps = .Machine$double.eps,
|
|
118 |
na.form = "NA")
|
|
119 |
{
|
|
120 |
if ((has.na <- any(ina <- is.na(pv))))
|
|
121 |
pv <- pv[!ina]
|
|
122 |
r <- character(length(is0 <- pv < eps))
|
|
123 |
if (any(!is0)) {
|
|
124 |
rr <- pv <- pv[!is0]
|
|
125 |
expo <- floor(log10(pv))
|
|
126 |
fixp <- expo >= -3 | (expo == -4 & digits > 1)
|
|
127 |
if (any(fixp))
|
|
128 |
rr[fixp] <- format(pv[fixp], dig = digits)
|
|
129 |
if (any(!fixp))
|
|
130 |
rr[!fixp] <- format(pv[!fixp], dig = digits)
|
|
131 |
r[!is0] <- rr
|
|
132 |
}
|
|
133 |
if (any(is0)) {
|
|
134 |
digits <- max(1, digits - 2)
|
|
135 |
if (any(!is0)) {
|
|
136 |
nc <- max(nchar(rr))
|
|
137 |
if (digits > 1 && digits + 6 > nc)
|
|
138 |
digits <- max(1, nc - 7)
|
|
139 |
sep <- if (digits == 1 && nc <= 6)
|
|
140 |
""
|
|
141 |
else " "
|
|
142 |
}
|
|
143 |
else sep <- if (digits == 1)
|
|
144 |
""
|
|
145 |
else " "
|
|
146 |
r[is0] <- paste("<", format(eps, digits = digits), sep = sep)
|
|
147 |
}
|
|
148 |
if (has.na) {
|
|
149 |
rok <- r
|
|
150 |
r <- character(length(ina))
|
|
151 |
r[!ina] <- rok
|
|
152 |
r[ina] <- na.form
|
|
153 |
}
|
|
154 |
r
|
|
155 |
}
|
|
156 |
|
|
157 |
"%in%" <- function (x, table) match(x, table, nomatch = 0) > 0
|
|
158 |
|
|
159 |
strwidth <- function(...)
|
|
160 |
{
|
|
161 |
par("cin")[1] / par("fin")[1] * (par("usr")[2] - par("usr")[1])
|
|
162 |
}
|
|
163 |
|
|
164 |
strheight <- function(...)
|
|
165 |
{
|
|
166 |
par("cin")[2] / par("fin")[2] * (par("usr")[4] - par("usr")[3])
|
|
167 |
}
|
|
168 |
|
|
169 |
boxplot.formula <- function(x, data = sys.parent(), ..., ask = TRUE)
|
|
170 |
{
|
|
171 |
if(!inherits(x, "formula"))
|
|
172 |
x <- as.formula(x)
|
|
173 |
|
|
174 |
mf <- model.frame(x, data, na.action = function(z) z)
|
|
175 |
if(length(names(mf)) > 2)
|
|
176 |
stop("boxplot.formula only accepts models with 1 predictor")
|
|
177 |
|
|
178 |
resp <- attr(attr(mf, "terms"), "response")
|
|
179 |
class(mf) <- NULL
|
|
180 |
y <- mf[[resp]]
|
|
181 |
x <- mf[[-resp]]
|
|
182 |
xlab <- names(mf)[-resp]
|
|
183 |
ylab <- names(mf)[resp]
|
|
184 |
|
|
185 |
boxplot(split(y, x), xlab = xlab, ylab = ylab, ...)
|
|
186 |
}
|
|
187 |
|
|
188 |
nlevels <- function(x) length(levels(x))
|
|
189 |
|
|
190 |
NULL
|
|
191 |
|
|
192 |
}
|
|
193 |
addLast <- function( fun )
|
|
194 |
{
|
|
195 |
if (!is.function(fun)) stop("fun must be a function")
|
|
196 |
if(!exists(".Last", env=.GlobalEnv))
|
|
197 |
assign(".Last", fun, env=.GlobalEnv)
|
|
198 |
else
|
|
199 |
{
|
|
200 |
Last <- get(".Last", env=.GlobalEnv)
|
|
201 |
newfun <- function(...)
|
|
202 |
{
|
|
203 |
fun()
|
|
204 |
Last()
|
|
205 |
}
|
|
206 |
assign(".Last", newfun, env=.GlobalEnv)
|
|
207 |
}
|
|
208 |
}
|
|
209 |
## useful function, raises an error if the FLAG expression is FALSE
|
|
210 |
assert <- function( FLAG )
|
|
211 |
{
|
|
212 |
if(!all(FLAG))
|
|
213 |
stop("Failed Assertion")
|
|
214 |
}
|
|
215 |
# $Id: combinations.R,v 1.7 2005/06/09 14:20:28 nj7w Exp $
|
|
216 |
#
|
|
217 |
|
|
218 |
##
|
|
219 |
## From email by Brian D Ripley <ripley@stats.ox.ac.uk> to r-help
|
|
220 |
## dated Tue, 14 Dec 1999 11:14:04 +0000 (GMT) in response to
|
|
221 |
## Alex Ahgarin <datamanagement@email.com>. Original version was
|
|
222 |
## named "subsets" and was Written by Bill Venables.
|
|
223 |
##
|
|
224 |
|
|
225 |
combinations <- function(n, r, v = 1:n, set = TRUE, repeats.allowed=FALSE)
|
|
226 |
{
|
|
227 |
if(mode(n) != "numeric" || length(n) != 1
|
|
228 |
|| n < 1 || (n %% 1) != 0) stop("bad value of n")
|
|
229 |
if(mode(r) != "numeric" || length(r) != 1
|
|
230 |
|| r < 1 || (r %% 1) != 0) stop("bad value of r")
|
|
231 |
if(!is.atomic(v) || length(v) < n)
|
|
232 |
stop("v is either non-atomic or too short")
|
|
233 |
if( (r > n) & repeats.allowed==FALSE)
|
|
234 |
stop("r > n and repeats.allowed=FALSE")
|
|
235 |
if(set) {
|
|
236 |
v <- unique(sort(v))
|
|
237 |
if (length(v) < n) stop("too few different elements")
|
|
238 |
}
|
|
239 |
v0 <- vector(mode(v), 0)
|
|
240 |
## Inner workhorse
|
|
241 |
if(repeats.allowed)
|
|
242 |
sub <- function(n, r, v)
|
|
243 |
{
|
|
244 |
if(r == 0) v0 else
|
|
245 |
if(r == 1) matrix(v, n, 1) else
|
|
246 |
if(n == 1) matrix(v, 1, r) else
|
|
247 |
rbind( cbind(v[1], Recall(n, r-1, v)),
|
|
248 |
Recall(n-1, r, v[-1]))
|
|
249 |
}
|
|
250 |
else
|
|
251 |
sub <- function(n, r, v)
|
|
252 |
{
|
|
253 |
if(r == 0) v0 else
|
|
254 |
if(r == 1) matrix(v, n, 1) else
|
|
255 |
if(r == n) matrix(v, 1, n) else
|
|
256 |
rbind(cbind(v[1], Recall(n-1, r-1, v[-1])),
|
|
257 |
Recall(n-1, r, v[-1]))
|
|
258 |
}
|
|
259 |
sub(n, r, v[1:n])
|
|
260 |
}
|
|
261 |
|
|
262 |
##
|
|
263 |
## Original version by Bill Venables and cited by by Matthew
|
|
264 |
## Wiener (mcw@ln.nimh.nih.gov) in an email to R-help dated
|
|
265 |
## Tue, 14 Dec 1999 09:11:32 -0500 (EST) in response to
|
|
266 |
## Alex Ahgarin <datamanagement@email.com>
|
|
267 |
##
|
|
268 |
##
|
|
269 |
|
|
270 |
|
|
271 |
permutations <- function(n, r, v = 1:n, set = TRUE, repeats.allowed=FALSE)
|
|
272 |
{
|
|
273 |
if(mode(n) != "numeric" || length(n) != 1
|
|
274 |
|| n < 1 || (n %% 1) != 0) stop("bad value of n")
|
|
275 |
if(mode(r) != "numeric" || length(r) != 1
|
|
276 |
|| r < 1 || (r %% 1) != 0) stop("bad value of r")
|
|
277 |
if(!is.atomic(v) || length(v) < n)
|
|
278 |
stop("v is either non-atomic or too short")
|
|
279 |
if( (r > n) ) #& repeats.allowed==FALSE)
|
|
280 |
stop("r > n") # and repeats.allowed=FALSE")
|
|
281 |
if(set) {
|
|
282 |
v <- unique(sort(v))
|
|
283 |
if (length(v) < n) stop("too few different elements")
|
|
284 |
}
|
|
285 |
v0 <- vector(mode(v), 0)
|
|
286 |
## Inner workhorse
|
|
287 |
if(repeats.allowed)
|
|
288 |
sub <- function(n, r, v)
|
|
289 |
{
|
|
290 |
if(r==1) matrix(v,n,1) else
|
|
291 |
if(n==1) matrix(v,1,r) else
|
|
292 |
{
|
|
293 |
inner <- Recall(n, r-1, v)
|
|
294 |
cbind( rep( v, rep(nrow(inner),n) ),
|
|
295 |
matrix( t(inner), ncol=ncol(inner), nrow=nrow(inner) * n ,
|
|
296 |
byrow=TRUE )
|
|
297 |
)
|
|
298 |
}
|
|
299 |
}
|
|
300 |
else
|
|
301 |
sub <- function(n, r, v)
|
|
302 |
{
|
|
303 |
if(r==1) matrix(v,n,1) else
|
|
304 |
if(n==1) matrix(v,1,r) else
|
|
305 |
{
|
|
306 |
X <- NULL
|
|
307 |
for(i in 1:n)
|
|
308 |
X <- rbind( X, cbind( v[i], Recall(n-1, r - 1, v[-i])))
|
|
309 |
X
|
|
310 |
}
|
|
311 |
}
|
|
312 |
|
|
313 |
sub(n, r, v[1:n])
|
|
314 |
}
|
|
315 |
## Code from
|
|
316 |
##
|
|
317 |
## @Article{Rnews:Lumley:2001,
|
|
318 |
## author = {Thomas Lumley},
|
|
319 |
## title = {Programmer's Niche: Macros in {R}},
|
|
320 |
## journal = {R News},
|
|
321 |
## year = 2001,
|
|
322 |
## volume = 1,
|
|
323 |
## number = 3,
|
|
324 |
## pages = {11--13},
|
|
325 |
## month = {September},
|
|
326 |
## url = {http://CRAN.R-project.org/doc/Rnews/}
|
|
327 |
##}
|
|
328 |
defmacro <- function(..., expr) #, DOTS=FALSE)
|
|
329 |
{
|
|
330 |
expr <- substitute(expr)
|
|
331 |
a <- substitute(list(...))[-1]
|
|
332 |
|
|
333 |
## process the argument list
|
|
334 |
nn <- names(a)
|
|
335 |
if (is.null(nn))
|
|
336 |
nn <- rep("", length(a))
|
|
337 |
for(i in 1:length(a))
|
|
338 |
{
|
|
339 |
if (nn[i] == "")
|
|
340 |
{
|
|
341 |
nn[i] <- paste(a[[i]])
|
|
342 |
msg <- paste(a[[i]], "not supplied")
|
|
343 |
a[[i]] <- substitute(stop(foo),
|
|
344 |
list(foo = msg))
|
|
345 |
}
|
|
346 |
if (nn[i] == "DOTS")
|
|
347 |
{
|
|
348 |
nn[i] <- "..."
|
|
349 |
a[[i]] <- formals(function(...){})[[1]]
|
|
350 |
}
|
|
351 |
}
|
|
352 |
names(a) <- nn
|
|
353 |
a <- as.list(a)
|
|
354 |
|
|
355 |
## this is where the work is done
|
|
356 |
ff <- eval(substitute(
|
|
357 |
function()
|
|
358 |
{
|
|
359 |
tmp <- substitute(body)
|
|
360 |
eval(tmp, parent.frame())
|
|
361 |
},
|
|
362 |
list(body = expr)))
|
|
363 |
|
|
364 |
## add the argument list
|
|
365 |
formals(ff) <- a
|
|
366 |
|
|
367 |
## create a fake source attribute
|
|
368 |
mm <- match.call()
|
|
369 |
mm$expr <- NULL
|
|
370 |
mm[[1]] <- as.name("macro")
|
|
371 |
attr(ff, "source") <- c(deparse(mm),
|
|
372 |
deparse(expr))
|
|
373 |
|
|
374 |
## return the 'macro'
|
|
375 |
ff
|
|
376 |
}
|
|
377 |
|
|
378 |
# $Id: dirichlet.R,v 1.4 2005/06/09 14:20:28 nj7w Exp $
|
|
379 |
|
|
380 |
# Posted by Ben Bolker to R-News on Fri Dec 15 2000
|
|
381 |
# http://www.r-project.org/nocvs/mail/r-help/2000/3865.html
|
|
382 |
#
|
|
383 |
# Some code (originally contributed by Ian Wilson
|
|
384 |
# <i.wilson@maths.abdn.ac.uk>
|
|
385 |
|
|
386 |
|
|
387 |
# functions for the "Dirichlet function", the multidimensional
|
|
388 |
# generalization of the beta distribution: it's the Bayesian
|
|
389 |
# canonical # distribution for the parameter estimates of a
|
|
390 |
# multinomial distribution.
|
|
391 |
|
|
392 |
# "pdirichlet" and "qdirichlet" (distribution function and quantiles)
|
|
393 |
# would be more difficult because you'd first have to decide how to
|
|
394 |
# define the distribution function for a multivariate distribution
|
|
395 |
# ... I'm sure this could be done but I don't know how
|
|
396 |
|
|
397 |
|
|
398 |
|
|
399 |
ddirichlet<-function(x,alpha)
|
|
400 |
## probability density for the Dirichlet function, where x=vector of
|
|
401 |
## probabilities
|
|
402 |
## and (alpha-1)=vector of observed samples of each type
|
|
403 |
## ddirichlet(c(p,1-p),c(x1,x2)) == dbeta(p,x1,x2)
|
|
404 |
{
|
|
405 |
|
|
406 |
dirichlet1 <- function(x, alpha)
|
|
407 |
{
|
|
408 |
logD <- sum(lgamma(alpha)) - lgamma(sum(alpha))
|
|
409 |
s<-sum((alpha-1)*log(x))
|
|
410 |
exp(sum(s)-logD)
|
|
411 |
|
|
412 |
}
|
|
413 |
|
|
414 |
# make sure x is a matrix
|
|
415 |
if(!is.matrix(x))
|
|
416 |
if(is.data.frame(x))
|
|
417 |
x <- as.matrix(x)
|
|
418 |
else
|
|
419 |
x <- t(x)
|
|
420 |
|
|
421 |
if(!is.matrix(alpha))
|
|
422 |
alpha <- matrix( alpha, ncol=length(alpha), nrow=nrow(x), byrow=TRUE)
|
|
423 |
|
|
424 |
if( any(dim(x) != dim(alpha)) )
|
|
425 |
stop("Mismatch between dimensions of 'x' and 'alpha'.")
|
|
426 |
|
|
427 |
pd <- vector(length=nrow(x))
|
|
428 |
for(i in 1:nrow(x))
|
|
429 |
pd[i] <- dirichlet1(x[i,],alpha[i,])
|
|
430 |
|
|
431 |
# Enforce 0 <= x[i,j] <= 1, sum(x[i,]) = 1
|
|
432 |
pd[ apply( x, 1, function(z) any( z <0 | z > 1)) ] <- 0
|
|
433 |
pd[ apply( x, 1, function(z) all.equal(sum( z ),1) !=TRUE) ] <- 0
|
|
434 |
pd
|
|
435 |
}
|
|
436 |
|
|
437 |
|
|
438 |
rdirichlet<-function(n,alpha)
|
|
439 |
## generate n random deviates from the Dirichlet function with shape
|
|
440 |
## parameters alpha
|
|
441 |
{
|
|
442 |
l<-length(alpha);
|
|
443 |
x<-matrix(rgamma(l*n,alpha),ncol=l,byrow=TRUE);
|
|
444 |
sm<-x%*%rep(1,l);
|
|
445 |
x/as.vector(sm);
|
|
446 |
}
|
|
447 |
|
|
448 |
# $Id: foldchange.R,v 1.3 2005/06/09 14:20:29 nj7w Exp $
|
|
449 |
|
|
450 |
foldchange <- function(num,denom)
|
|
451 |
{
|
|
452 |
ifelse(num >= denom, num/denom, -denom/num)
|
|
453 |
}
|
|
454 |
|
|
455 |
|
|
456 |
# Compute foldchange from log-ratio values
|
|
457 |
logratio2foldchange <- function(logratio, base=2)
|
|
458 |
{
|
|
459 |
retval <- base^(logratio)
|
|
460 |
retval <- ifelse(retval < 1, -1/retval, retval)
|
|
461 |
retval
|
|
462 |
}
|
|
463 |
|
|
464 |
# vice versa
|
|
465 |
foldchange2logratio <- function(foldchange, base=2)
|
|
466 |
{
|
|
467 |
retval <- ifelse( foldchange<0, 1/-foldchange, foldchange)
|
|
468 |
retval <- log(retval,base)
|
|
469 |
retval
|
|
470 |
}
|
|
471 |
|
|
472 |
# $Id: invalid.R,v 1.4 2005/06/09 14:20:29 nj7w Exp $
|
|
473 |
|
|
474 |
invalid <- function(x)
|
|
475 |
{
|
|
476 |
if( missing(x) || is.null(x) || length(x)==0 )
|
|
477 |
return(TRUE)
|
|
478 |
if(is.list(x))
|
|
479 |
return(all(sapply(x,invalid)))
|
|
480 |
else if(is.vector(x))
|
|
481 |
return(all(is.na(x)))
|
|
482 |
else
|
|
483 |
return(FALSE)
|
|
484 |
}
|
|
485 |
# $Id: logit.R,v 1.2 2005/06/09 14:20:29 nj7w Exp $
|
|
486 |
|
|
487 |
logit <- function(x, min=0, max=1)
|
|
488 |
{
|
|
489 |
p <- (x-min)/(max-min)
|
|
490 |
log(p/(1-p))
|
|
491 |
}
|
|
492 |
|
|
493 |
inv.logit <- function(x, min=0, max=1)
|
|
494 |
{
|
|
495 |
p <- exp(x)/(1+exp(x))
|
|
496 |
p <- ifelse( is.na(p) & !is.na(x), 1, p ) # fix problems with +Inf
|
|
497 |
p * (max-min) + min
|
|
498 |
}
|
|
499 |
|
|
500 |
# $Id: mixedsort.R,v 1.10 2005/06/13 17:08:41 nj7w Exp $
|
|
501 |
|
|
502 |
mixedsort <- function(x) x[mixedorder(x)]
|
|
503 |
|
|
504 |
mixedorder <- function(x)
|
|
505 |
{
|
|
506 |
# - Split each each character string into an vector of strings and
|
|
507 |
# numbers
|
|
508 |
# - Separately rank numbers and strings
|
|
509 |
# - Combine orders so that strings follow numbers
|
|
510 |
|
|
511 |
delim="\\$\\@\\$"
|
|
512 |
|
|
513 |
numeric <- function(x)
|
|
514 |
{
|
|
515 |
optwarn = options("warn")
|
|
516 |
on.exit( options(optwarn) )
|
|
517 |
options(warn=-1)
|
|
518 |
as.numeric(x)
|
|
519 |
}
|
|
520 |
|
|
521 |
nonnumeric <- function(x)
|
|
522 |
{
|
|
523 |
optwarn = options("warn")
|
|
524 |
on.exit( options(optwarn) )
|
|
525 |
options(warn=-1)
|
|
526 |
|
|
527 |
ifelse(is.na(as.numeric(x)), toupper(x), NA)
|
|
528 |
}
|
|
529 |
|
|
530 |
|
|
531 |
x <- as.character(x)
|
|
532 |
|
|
533 |
which.nas <- which(is.na(x))
|
|
534 |
which.blanks <- which(x=="")
|
|
535 |
|
|
536 |
if(length(which.blanks) >0)
|
|
537 |
x[ which.blanks ] <- -Inf
|
|
538 |
if(length(which.nas) >0)
|
|
539 |
x[ which.nas ] <- Inf
|
|
540 |
|
|
541 |
####
|
|
542 |
# - Convert each character string into an vector containing single
|
|
543 |
# character and numeric values.
|
|
544 |
####
|
|
545 |
|
|
546 |
# find and mark numbers in the form of +1.23e+45.67
|
|
547 |
delimited <- gsub("([+-]{0,1}[0-9\.]+([eE][\+\-]{0,1}[0-9\.]+){0,1})",
|
|
548 |
paste(delim,"\\1",delim,sep=""), x)
|
|
549 |
|
|
550 |
# separate out numbers
|
|
551 |
step1 <- strsplit(delimited, delim)
|
|
552 |
|
|
553 |
# remove empty elements
|
|
554 |
step1 <- lapply( step1, function(x) x[x>""] )
|
|
555 |
|
|
556 |
# create numeric version of data
|
|
557 |
step1.numeric <- lapply( step1, numeric )
|
|
558 |
|
|
559 |
# create non-numeric version of data
|
|
560 |
step1.character <- lapply( step1, nonnumeric )
|
|
561 |
|
|
562 |
# now transpose so that 1st vector contains 1st element from each
|
|
563 |
# original string
|
|
564 |
maxelem <- max(sapply(step1, length))
|
|
565 |
|
|
566 |
step1.numeric.t <- lapply(1:maxelem,
|
|
567 |
function(i)
|
|
568 |
sapply(step1.numeric,
|
|
569 |
function(x)x[i])
|
|
570 |
)
|
|
571 |
|
|
572 |
step1.character.t <- lapply(1:maxelem,
|
|
573 |
function(i)
|
|
574 |
sapply(step1.character,
|
|
575 |
function(x)x[i])
|
|
576 |
)
|
|
577 |
|
|
578 |
# now order them
|
|
579 |
rank.numeric <- sapply(step1.numeric.t,rank)
|
|
580 |
rank.character <- sapply(step1.character.t,
|
|
581 |
function(x) as.numeric(factor(x)))
|
|
582 |
|
|
583 |
# and merge
|
|
584 |
rank.numeric[!is.na(rank.character)] <- 0 # mask off string values
|
|
585 |
|
|
586 |
rank.character <- t(
|
|
587 |
t(rank.character) +
|
|
588 |
apply(matrix(rank.numeric),2,max,na.rm=TRUE)
|
|
589 |
)
|
|
590 |
|
|
591 |
rank.overall <- ifelse(is.na(rank.character),rank.numeric,rank.character)
|
|
592 |
|
|
593 |
order.frame <- as.data.frame(rank.overall)
|
|
594 |
if(length(which.nas) > 0)
|
|
595 |
order.frame[which.nas,] <- Inf
|
|
596 |
retval <- do.call("order",order.frame)
|
|
597 |
|
|
598 |
return(retval)
|
|
599 |
}
|
|
600 |
|
|
601 |
|
|
602 |
# $Id: oddeven.R,v 1.3 2005/06/09 14:20:29 nj7w Exp $
|
|
603 |
|
|
604 |
# detect odd/even integers
|
|
605 |
odd <- function(x) x!=as.integer(x/2)*2
|
|
606 |
even <- function(x) x==as.integer(x/2)*2
|
|
607 |
# $Id: permute.R,v 1.3 2005/06/09 14:20:29 nj7w Exp $
|
|
608 |
|
|
609 |
permute <- function(x) sample( x, size=length(x), replace=FALSE )
|
|
610 |
# $Id: quantcut.R,v 1.4 2005/06/09 14:20:29 nj7w Exp $
|
|
611 |
|
|
612 |
quantcut <- function(x, q=seq(0,1,by=0.25), na.rm=TRUE, ... )
|
|
613 |
{
|
|
614 |
quant <- quantile(x, q, na.rm=na.rm)
|
|
615 |
dups <- duplicated(quant)
|
|
616 |
if(any(dups))
|
|
617 |
{
|
|
618 |
flag <- x %in% unique(quant[dups])
|
|
619 |
retval <- ifelse(flag,
|
|
620 |
paste("[",
|
|
621 |
as.character(x),
|
|
622 |
"]",
|
|
623 |
sep=''),
|
|
624 |
NA)
|
|
625 |
uniqs <- unique(quant)
|
|
626 |
|
|
627 |
# move cut points over a bit...
|
|
628 |
reposition <- function(cut)
|
|
629 |
{
|
|
630 |
flag <- x>=cut
|
|
631 |
if(sum(flag)==0)
|
|
632 |
return(cut)
|
|
633 |
else
|
|
634 |
return(min(x[flag], na.rm=na.rm))
|
|
635 |
}
|
|
636 |
|
|
637 |
newquant <- sapply(uniqs, reposition)
|
|
638 |
retval[!flag] <- as.character(cut(x[!flag],
|
|
639 |
breaks=newquant,
|
|
640 |
include.lowest=TRUE,...))
|
|
641 |
|
|
642 |
levs <- unique(retval[order(x)]) # ensure factor levels are
|
|
643 |
# properly ordered
|
|
644 |
retval <- factor(retval, levels=levs)
|
|
645 |
|
|
646 |
## determine open/closed interval ends
|
|
647 |
mkpairs <- function(x) # make table of lower, upper
|
|
648 |
sapply(x,
|
|
649 |
function(y) if(length(y)==2) y[c(2,2)] else y[2:3]
|
|
650 |
)
|
|
651 |
pairs <- mkpairs(strsplit(levs, '[^0-9+\\.\\-]+', extended=TRUE))
|
|
652 |
rownames(pairs) <- c("lower.bound","upper.bound")
|
|
653 |
colnames(pairs) <- levs
|
|
654 |
|
|
655 |
closed.lower <- rep(F,ncol(pairs)) # default lower is open
|
|
656 |
closed.upper <- rep(T,ncol(pairs)) # default upper is closed
|
|
657 |
closed.lower[1] <- TRUE # lowest interval is always closed
|
|
658 |
|
|
659 |
for(i in 2:ncol(pairs)) # open lower interval if above singlet
|
|
660 |
if(pairs[1,i]==pairs[1,i-1] && pairs[1,i]==pairs[2,i-1])
|
|
661 |
closed.lower[i] <- FALSE
|
|
662 |
|
|
663 |
for(i in 1:(ncol(pairs)-1)) # open upper inteval if below singlet
|
|
664 |
if(pairs[2,i]==pairs[1,i+1] && pairs[2,i]==pairs[2,i+1])
|
|
665 |
closed.upper[i] <- FALSE
|
|
666 |
|
|
667 |
levs <- ifelse(pairs[1,]==pairs[2,],
|
|
668 |
pairs[1,],
|
|
669 |
paste(ifelse(closed.lower,"[","("),
|
|
670 |
pairs[1,],
|
|
671 |
",",
|
|
672 |
pairs[2,],
|
|
673 |
ifelse(closed.upper,"]",")"),
|
|
674 |
sep='')
|
|
675 |
)
|
|
676 |
levels(retval) <- levs
|
|
677 |
}
|
|
678 |
else
|
|
679 |
retval <- cut( x, quant, include.lowest=TRUE, ... )
|
|
680 |
return(retval)
|
|
681 |
}
|
|
682 |
# $Id: running.R,v 1.12 2005/06/09 14:20:29 nj7w Exp $
|
|
683 |
|
|
684 |
"running" <- function(X, Y=NULL,
|
|
685 |
fun=mean,
|
|
686 |
width=min(length(X), 20),
|
|
687 |
allow.fewer=FALSE, pad=FALSE,
|
|
688 |
align=c("right", "center", "left"),
|
|
689 |
simplify=TRUE,
|
|
690 |
by, # added a parameter
|
|
691 |
...)
|
|
692 |
{
|
|
693 |
align=match.arg(align)
|
|
694 |
|
|
695 |
n <- length(X)
|
|
696 |
|
|
697 |
if (align=="left")
|
|
698 |
{
|
|
699 |
from <- 1:n
|
|
700 |
to <- pmin( (1:n)+width-1, n)
|
|
701 |
}
|
|
702 |
else if (align=="right")
|
|
703 |
{
|
|
704 |
from <- pmax( (1:n)-width+1, 1)
|
|
705 |
to <- 1:n
|
|
706 |
}
|
|
707 |
else #align=="center"
|
|
708 |
{
|
|
709 |
from <- pmax((2-width):n,1)
|
|
710 |
to <- pmin(1:(n+width-1),n)
|
|
711 |
if(!odd(width)) stop("width must be odd for center alignment")
|
|
712 |
|
|
713 |
}
|
|
714 |
|
|
715 |
elements <- apply(cbind(from, to), 1, function(x) seq(x[1], x[2]) )
|
|
716 |
|
|
717 |
if(is.matrix(elements))
|
|
718 |
elements <- as.data.frame(elements) # ensure its a list!
|
|
719 |
|
|
720 |
names(elements) <- paste(from,to,sep=':')
|
|
721 |
|
|
722 |
if(!allow.fewer)
|
|
723 |
{
|
|
724 |
len <- sapply(elements, length)
|
|
725 |
skip <- (len < width)
|
|
726 |
}
|
|
727 |
else
|
|
728 |
{
|
|
729 |
skip <- 0
|
|
730 |
}
|
|
731 |
|
|
732 |
|
|
733 |
run.elements <- elements[!skip]
|
|
734 |
|
|
735 |
if(!invalid(by))
|
|
736 |
run.elements <- run.elements[seq(from=1, to=length(run.elements),
|
|
737 |
by=by)]
|
|
738 |
|
|
739 |
|
|
740 |
if(is.null(Y)) # univariate
|
|
741 |
{
|
|
742 |
funct <- function(which,what,fun,...) fun(what[which],...)
|
|
743 |
|
|
744 |
if(simplify)
|
|
745 |
Xvar <- sapply(run.elements, funct, what=X, fun=fun, ...)
|
|
746 |
else
|
|
747 |
Xvar <- lapply(run.elements, funct, what=X, fun=fun, ...)
|
|
748 |
}
|
|
749 |
else # bivariate
|
|
750 |
{
|
|
751 |
funct <- function(which,XX,YY,fun,...) fun(XX[which],YY[which], ...)
|
|
752 |
|
|
753 |
if(simplify)
|
|
754 |
Xvar <- sapply(run.elements, funct, XX=X, YY=Y, fun=fun, ...)
|
|
755 |
else
|
|
756 |
Xvar <- lapply(run.elements, funct, XX=X, YY=Y, fun=fun, ...)
|
|
757 |
}
|
|
758 |
|
|
759 |
|
|
760 |
if(allow.fewer || !pad)
|
|
761 |
return(Xvar)
|
|
762 |
|
|
763 |
if(simplify)
|
|
764 |
if(is.matrix(Xvar))
|
|
765 |
{
|
|
766 |
wholemat <- matrix( new(class(Xvar[1,1]), NA),
|
|
767 |
ncol=length(to), nrow=nrow(Xvar) )
|
|
768 |
colnames(wholemat) <- paste(from,to,sep=':')
|
|
769 |
wholemat[,-skip] <- Xvar
|
|
770 |
Xvar <- wholemat
|
|
771 |
}
|
|
772 |
else
|
|
773 |
{
|
|
774 |
wholelist <- rep(new(class(Xvar[1]),NA),length(from))
|
|
775 |
names(wholelist) <- names(elements)
|
|
776 |
wholelist[ names(Xvar) ] <- Xvar
|
|
777 |
Xvar <- wholelist
|
|
778 |
}
|
|
779 |
|
|
780 |
return(Xvar)
|
|
781 |
}
|
|
782 |
|
|
783 |
# $Id: scat.R,v 1.2 2005/06/09 14:20:29 nj7w Exp $
|
|
784 |
|
|
785 |
# cat to stdout and immediately flush
|
|
786 |
scat <- function(...)
|
|
787 |
{
|
|
788 |
DEBUG <- options()$DEBUG
|
|
789 |
if( !is.null(DEBUG) && DEBUG)
|
|
790 |
{
|
|
791 |
cat("### ", file=stderr())
|
|
792 |
cat(..., file=stderr())
|
|
793 |
cat(" ###\n", file=stderr())
|
|
794 |
flush(stderr())
|
|
795 |
}
|
|
796 |
invisible(NULL)
|
|
797 |
}
|
|
798 |
setTCPNoDelay <- function( socket, value=TRUE )
|
|
799 |
{
|
|
800 |
if(!any(c("socket","sockconn") %in% class(socket)))
|
|
801 |
stop("socket must be a socket object")
|
|
802 |
|
|
803 |
buffer <- paste(rep(" ", 1000), sep='', collapse='')
|
|
804 |
|
|
805 |
conn <- getConnection(socket[1])
|
|
806 |
|
|
807 |
retval <- .C("R_setTCPNoDelay",
|
|
808 |
socket=as.integer(socket[1]),
|
|
809 |
flag=as.integer(value),
|
|
810 |
status=integer(1),
|
|
811 |
status.str=as.character(buffer),
|
|
812 |
status.len=as.integer(nchar(buffer)),
|
|
813 |
package="gtools"
|
|
814 |
)
|
|
815 |
|
|
816 |
if(retval$status != 0)
|
|
817 |
stop( retval$status.str )
|
|
818 |
else
|
|
819 |
invisible(retval$status.str)
|
|
820 |
}
|
|
821 |
|
|
822 |
strmacro <- function(..., expr, strexpr)
|
|
823 |
{
|
|
824 |
if(!missing(expr))
|
|
825 |
strexpr <- deparse(substitute(expr))
|
|
826 |
|
|
827 |
a <- substitute(list(...))[-1]
|
|
828 |
|
|
829 |
nn <- names(a)
|
|
830 |
if (is.null(nn))
|
|
831 |
nn <- rep("", length(a))
|
|
832 |
for(i in 1:length(a))
|
|
833 |
{
|
|
834 |
if (nn[i] == "")
|
|
835 |
{
|
|
836 |
nn[i] <- paste(a[[i]])
|
|
837 |
msg <- paste(a[[i]], "not supplied")
|
|
838 |
a[[i]] <- substitute(stop(foo),
|
|
839 |
list(foo = msg))
|
|
840 |
}
|
|
841 |
else
|
|
842 |
{
|
|
843 |
a[[i]] <- a[[i]]
|
|
844 |
}
|
|
845 |
#if (nn[i] == "DOTS")
|
|
846 |
# {
|
|
847 |
# nn[i] <- "..."
|
|
848 |
# a[[i]] <- formals(function(...){})[[1]]
|
|
849 |
# }
|
|
850 |
}
|
|
851 |
names(a) <- nn
|
|
852 |
a <- as.list(a)
|
|
853 |
|
|
854 |
## this is where the work is done
|
|
855 |
ff <-
|
|
856 |
function(...)
|
|
857 |
{
|
|
858 |
## build replacement list
|
|
859 |
reptab <- a # copy defaults first
|
|
860 |
reptab$"..." <- NULL
|
|
861 |
#reptab$DOTS <- ""
|
|
862 |
|
|
863 |
args <- match.call(expand.dots=TRUE)[-1]
|
|
864 |
#print(args)
|
|
865 |
|
|
866 |
for(item in names(args))
|
|
867 |
##if(item %in% names(reptab))
|
|
868 |
reptab[[item]] <- args[[item]]
|
|
869 |
##else
|
|
870 |
## {
|
|
871 |
## browser()
|
|
872 |
## oldval <- reptab[["DOTS"]]
|
|
873 |
## addval <- paste(item, "=", args[[item]])
|
|
874 |
## if(oldval>"")
|
|
875 |
## newval <- paste(c(oldval, addval), collapse=", ")
|
|
876 |
## else
|
|
877 |
## newval <- addval
|
|
878 |
## reptab[["DOTS"]] <- newval
|
|
879 |
## }
|
|
880 |
|
|
881 |
#print(reptab)
|
|
882 |
|
|
883 |
## do the replacements
|
|
884 |
body <- strexpr
|
|
885 |
for(i in 1:length(reptab))
|
|
886 |
{
|
|
887 |
pattern <- paste("\\b",
|
|
888 |
names(reptab)[i],
|
|
889 |
"\\b",sep='')
|
|
890 |
|
|
891 |
value <- reptab[[i]]
|
|
892 |
if(missing(value))
|
|
893 |
value <- ""
|
|
894 |
|
|
895 |
body <- gsub(pattern,
|
|
896 |
value,
|
|
897 |
body,
|
|
898 |
extended=TRUE)
|
|
899 |
}
|
|
900 |
|
|
901 |
#print(body)
|
|
902 |
|
|
903 |
fun <- parse(text=body)
|
|
904 |
eval(fun, parent.frame())
|
|
905 |
|
|
906 |
|
|
907 |
}
|
|
908 |
|
|
909 |
|
|
910 |
|
|
911 |
## add the argument list
|
|
912 |
formals(ff) <- a
|
|
913 |
|
|
914 |
## create a fake source attribute
|
|
915 |
mm <- match.call()
|
|
916 |
mm$expr <- NULL
|
|
917 |
mm[[1]] <- as.name("macro")
|
|
918 |
attr(ff, "source") <- c(deparse(mm), strexpr)
|
|
919 |
|
|
920 |
## return the 'macro'
|
|
921 |
ff
|
|
922 |
}
|
|
923 |
|
|
924 |
|
|
925 |
|
|
926 |
|