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
|
#### Skewness (MC) - Adjusted Boxplots
### modeled closely after boxplot() etc in R/src/library/graphics/R/boxplot.R :
adjbox <- function(x, ...) UseMethod("adjbox")
adjbox.default <- function (x, ..., range = 1.5, width = NULL, varwidth = FALSE,
notch = FALSE, outline = TRUE, names, plot = TRUE, border = par("fg"),
col = NULL, log = "", pars = list(boxwex = 0.8, staplewex = 0.5,
outwex = 0.5), horizontal = FALSE, add = FALSE, at = NULL)
{
args <- list(x, ...)
namedargs <-
if(!is.null(attributes(args)$names))
attributes(args)$names != ""
else
rep(FALSE, length.out = length(args))
## pars <- c(args[namedargs], pars)
groups <- if(is.list(x)) x else args[!namedargs]
if(0 == (n <- length(groups)))
stop("invalid first argument")
if(length(class(groups)))
groups <- unclass(groups)
if(!missing(names))
attr(groups, "names") <- names
else {
if(is.null(attr(groups, "names")))
attr(groups, "names") <- 1:n
names <- attr(groups, "names")
}
cls <- sapply(groups, function(x) class(x)[1])
cl <- if (all(cls == cls[1]))
cls[1]
else NULL
for (i in 1:n)
groups[i] <- list(adjboxStats(unclass(groups[[i]]), range)) # do.conf=notch)
stats <- matrix(0, nrow=5, ncol=n)
conf <- matrix(0, nrow=2, ncol=n)
ng <- out <- group <- numeric(0)
ct <- 1
for(i in groups) {
stats[,ct] <- i$stats
conf [,ct] <- i$conf
ng <- c(ng, i$n)
if((lo <- length(i$out))) {
out <- c(out,i$out)
group <- c(group, rep.int(ct, lo))
}
ct <- ct+1
}
if(length(cl) && cl != "numeric") oldClass(stats) <- cl
z <- list(stats = stats, n = ng, conf = conf, out = out, group = group,
names = names)
if(plot) {
if(is.null(pars$boxfill) && is.null(args$boxfill)) pars$boxfill <- col
do.call("bxp",
c(list(z, notch = notch, width = width, varwidth = varwidth,
log = log, border = border, pars = pars,
outline = outline, horizontal = horizontal, add = add,
at = at), args[namedargs]))
invisible(z)
}
else z
}
adjbox.formula <- function (formula, data = NULL, ..., subset, na.action = NULL)
{
if(missing(formula) || (length(formula) != 3))
stop("'formula' missing or incorrect")
m <- match.call(expand.dots = FALSE)
if(is.matrix(eval(m$data, parent.frame())))
m$data <- as.data.frame(data)
m$... <- NULL
m$na.action <- na.action # force use of default for this method
require(stats, quietly = TRUE)
m[[1]] <- as.name("model.frame")
mf <- eval(m, parent.frame())
response <- attr(attr(mf, "terms"), "response")
adjbox(split(mf[[response]], mf[-response]), ...)
}
## modeled after boxplot.stats() from R/src/library/grDevices/R/calc.R :
adjboxStats <-
function (x, coef = 1.5, a = -4, b = 3, do.conf = TRUE, do.out = TRUE)
{
if(coef < 0) stop("'coef' must not be negative")
nna <- !is.na(x)
n <- sum(nna) # including +/- Inf
stats <- stats::fivenum(x, na.rm = TRUE)
iqr <- diff(stats[c(2, 4)])
if(coef == 0)
do.out <- FALSE # no whiskers to be drawn
else { ## coef > 0
out <- if (!is.na(iqr)) {
medc <- mc(x, na.rm = TRUE)
if (medc >= 0) {
x < (stats[2] - coef * exp(a * medc) * iqr) |
x > (stats[4] + coef * exp(b * medc) * iqr)
} else {
x < (stats[2] - coef * exp(-b * medc) * iqr) |
x > (stats[4] + coef * exp( a * medc) * iqr)
}
}
else !is.finite(x)
if (any(out[nna], na.rm = TRUE))
stats[c(1, 5)] <- range(x[!out], na.rm = TRUE)
}
conf <- if (do.conf) stats[3] + c(-1.58, 1.58) * iqr/sqrt(n)
list(stats = stats, n = n, conf = conf,
out = if (do.out) x[out & nna] else numeric(0))
}
|
