-
Notifications
You must be signed in to change notification settings - Fork 5
/
ogive.R
142 lines (125 loc) · 4.49 KB
/
ogive.R
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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
### actuar: Actuarial Functions and Heavy Tailed Distributions
###
### Ogive for grouped data.
###
### A default method exists for either a vector of individual data, or
### two vectors of group boundaries and group frequencies. It first
### creates a grouped data object using 'grouped.data' and then calls
### a utility function to create the ogive.
###
### For the definition of the ogive, see Klugman, Panjer & Willmot,
### Loss Models, Wiley, 1998.
###
### More details on the admissible arguments for the default method
### are to be found in ./grouped.data.R.
###
### AUTHORS: Vincent Goulet <[email protected]>,
### Mathieu Pigeon
###
### CREDITS: Arguments, 'breaks', 'nclass' and their treatment taken
### from R function hist().
ogive <- function(x, ...) UseMethod("ogive")
ogive.default <- function(x, y = NULL,
breaks = "Sturges", nclass = NULL, ...)
{
chkDots(...) # method does not use '...'
Call <- match.call()
if (exists(".Generic", inherits = FALSE))
Call[[1]] <- as.name(.Generic)
## Avoid using calling 'hist' with 'nclass' specified.
if (!missing(breaks))
{
if (!missing(nclass))
warning(sprintf("%s not used when %s is specified",
sQuote("nclass"), sQuote("breaks")))
}
else if (!is.null(nclass) && length(nclass) == 1L)
breaks <- nclass
## Create the "grouped.data" object.
x <- if (is.null(y)) # one argument: individual data
grouped.data(x, breaks = breaks)
else # two arguments: boundaries and frequencies
grouped.data(x, y)
## Group frequencies in the second column of the data frame; group
## boundaries in the environment of 'x'.
y <- x[, 2L]
x <- eval(expression(cj), envir = environment(x))
## Create an object of class 'ogive'.
res <- .ogiveFUN(x, y)
attr(res, "call") <- Call
res
}
ogive.grouped.data <- function(x, ...)
{
chkDots(...) # method does not use '...'
Call <- match.call()
if (exists(".Generic", inherits = FALSE))
Call[[1]] <- as.name(.Generic)
## We keep the first frequencies column only; group boundaries are
## in the environment of 'x'
y <- x[, 2L]
x <- eval(expression(cj), envir = environment(x))
## Create an object of class 'ogive'.
res <- .ogiveFUN(x, y)
attr(res, "call") <- Call
res
}
.ogiveFUN <- function(x, y)
{
FUN <- approxfun(x, cumsum(c(0, y)) / sum(y), yleft = 0, yright = 1,
method = "linear", ties = "ordered")
class(FUN) <- c("ogive", class(FUN))
FUN
}
### Essentially identical to stats:::print.ecdf.
print.ogive <- function(x, digits = getOption("digits") - 2, ...)
{
## Utility function
numform <- function(x) paste(formatC(x, digits = digits), collapse = ", ")
## The rest is adapted from stats::ecdf
cat("Ogive for grouped data \nCall: ")
print(attr(x, "call"), ...)
nc <- length(xxc <- get("x", envir = environment(x)))
nn <- length(xxn <- get("y", envir = environment(x)))
i1 <- 1L:min(3L, nc)
i2 <- if (nc >= 4L) max(4L, nc - 1L):nc else integer(0)
i3 <- 1L:min(3L, nn)
i4 <- if (nn >= 4L) max(4L, nn - 1L):nn else integer(0)
cat(" x = ", numform(xxc[i1]), if (nc > 3L) ", ",
if (nc > 5L) " ..., ", numform(xxc[i2]), "\n", sep = "")
cat(" F(x) = ", numform(xxn[i3]), if (nn > 3L) ", ",
if (nn > 5L) " ..., ", numform(xxn[i4]), "\n", sep = "")
invisible(x)
}
### Essentially identical to stats:::summary.ecdf.
summary.ogive <- function (object, ...)
{
n <- length(eval(expression(x), envir = environment(object)))
header <- paste("Ogive: ", n,
"unique values with summary\n")
structure(summary(knots(object), ...),
header = header, class = "summary.ogive")
}
### Identical to stats:::print.summary.ecdf.
print.summary.ogive <- function(x, ...)
{
cat(attr(x, "header"))
y <- x; attr(y, "header") <- NULL; class(y) <- "summaryDefault"
print(y, ...)
invisible(x)
}
### Identical to stats:::knots.stepfun.
knots.ogive <- function(Fn, ...)
eval(expression(x), envir = environment(Fn))
plot.ogive <- function(x, main = NULL, xlab = "x", ylab = "F(x)", ...)
{
if (missing(main))
main <- {
cl <- attr(x, "call")
deparse(if (!is.null(cl)) cl else sys.call())
}
kn <- knots(x)
Fn <- x(kn)
plot(kn, Fn, ..., type = "o", pch = 16,
main = main, xlab = xlab, ylab = ylab)
}