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
|
score.binary <- function(..., fun=max, points=1:p,
na.rm=funtext=='max', retfactor=TRUE)
{
x <- list(...)
p <- length(x)
nam <- (as.character(sys.call())[-1])[1:p]
x <- matrix(unlist(x), ncol=p)
if(!missing(points)) {
if(length(points)==1)
points <- rep(points, p)
if(length(points)!=p)
stop('wrong length for points')
}
x <- x * rep(points, rep.int(nrow(x),p))
funtext <- as.character(substitute(fun))
if(funtext=='max' && !missing(points) && retfactor)
warning('points do not matter for fun=max with retfactor=T\nas long as they are in ascending order')
if(!missing(retfactor) && retfactor && funtext!='max')
stop('retfactor=T only applies to fun=max')
xna <- apply(x, 1, function(x) any(is.na(x)))
if(.R.) {
funargs <- as.list(args(fun))
funargs <- funargs[-length(funargs)]
if(any(names(funargs) == "na.rm")) {
x <- apply(x, 1, fun, na.rm=na.rm)
} else {
x <- apply(x, 1, fun)
}
} else {
fun$na.rm <- na.rm
x <- apply(x, 1, fun)
}
if(!na.rm)
x[x==0 & xna] <- NA
if(retfactor && funtext=='max')
factor(x, c(0,points), c("none",nam))
else x
}
|
