-
Notifications
You must be signed in to change notification settings - Fork 2
/
stats.R
174 lines (170 loc) · 5.77 KB
/
stats.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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
#' List the stats used by a plot
#'
#' \code{get_stats} returns a vector of stats names, written as character
#' strings, that describes which stats in which order are used by a plot.
#'
#' @param p A ggplot object
#'
#' @return A vector of character strings. Each element corresponds to the suffix
#' of a ggplot2 \code{stat_} function, e.g. \code{c("identity", "smooth")}.
#'
#' @family functions for checking stats
#'
#' @export
#'
#' @examples
#' require(ggplot2)
#' p <- ggplot(data = mpg, mapping = aes(x = displ, y = hwy)) +
#' geom_point(mapping = aes(color = class)) +
#' geom_smooth()
#' get_stats(p)
get_stats <- function(p) {
stop_if_not_ggplot(p)
n <- n_layers(p)
vapply(seq_len(n), ith_stat, character(1), p = p)
}
#' Does a plot use one or more stats?
#'
#' \code{uses_stats} tests whether a plot uses one or more stats in its layers.
#'
#' By default, the plot must have the exact stats or geom/stat combinations and in the same order.
#' However, if \code{exact} is set to \code{FALSE}, the plot stats or geom/stat combinations do not have to be exact.
#'
#' @param p A ggplot object
#' @param stats A vector of character strings. Each element should correspond to
#' the suffix of a ggplot2 \code{stat_} function, e.g. \code{c("identity", "smooth")}.
#' @param exact if \code{TRUE}, use exact matching
#' @param geoms A character vector to optionally check for the geoms corresponding to stats
#' e.g. c("point", "smooth") if checking c("identity", "smooth")
#'
#' @return \code{TRUE} or \code{FALSE}
#'
#' @family functions for checking stats
#'
#' @export
#'
#' @examples
#' require(ggplot2)
#' p <- ggplot(data = mpg, mapping = aes(x = displ, y = hwy)) +
#' geom_point(mapping = aes(color = class)) +
#' geom_smooth()
#' uses_stats(p, stats = "smooth")
#' uses_stats(p, stats = c("identity", "smooth"), exact = TRUE)
#' uses_stats(p, c("smooth", "identity"), geoms = c("smooth", "point"))
uses_stats <- function(p, stats, geoms = NULL, exact = TRUE) {
stop_if_not_ggplot(p)
# map the GEOM + STAT for plot and the instructor's target stats
stats <- lapply(stats, map_stat)
# if geoms is specified override the GEOM(s) defaults of geoms
if (!is.null(geoms)) {
# number of geoms have to be the same as number of stats.
if (length(geoms) != length(stats)) {
stop("Grading error: number of geoms supplied don't match number of stats.")
}
# map user supplied geoms suffixes to actual class names
geoms <- lapply(geoms, map_geom)
stats <- lapply(seq_along(stats), function(s) {
stats[[s]][["GEOM"]] <- geoms[[s]][["GEOM"]]
stats[[s]]
})
}
pstats <- get_geoms_stats(p)
if (exact) {
return(identical(stats, pstats))
} else {
return(all(stats %in% pstats))
}
}
#' Does a layer use a specific stat parameter?
#'
#' \code{uses_stat_param} is a mirror function of \code{uses_geom_param} but instead of checking a plot's
#' geom layer, it checks that a plot's stat layer uses a specific stat parameter.
#'
#' To specify a specific stat layer, either specify using position using the \code{i} index or
#' by using a combination of \code{stat} function suffix name and \code{i} to check the ith layer that
#' uses the stat.
#'
#' @param p A ggplot object
#' @param stat A character string found in the suffix of a ggplot2 stat function,
#' e.g. \code{"bin"}.
#' @param params A named list of stat or geom parameter values, e.g. \code{list(bins = 200)}
#' @param i A numerical index, e.g. \code{1}.
#'
#' @return A boolean
#' @export
#'
#' @examples
#' require(ggplot2)
#' p <- ggplot(diamonds, aes(carat)) +
#' stat_bin(bins = 200)
#' uses_stat_param(p, stat = "bin", params = list(bins = 200))
uses_stat_param <- function(p, stat, params, i = NULL) {
stop_if_not_ggplot(p)
layer <- get_stat_layer(p, stat = stat, i)$layer
user_params <- names(params)
# collect geom and stat parameters
all_params <- c(layer$geom_params, layer$stat_params)
p_params <- names(all_params)
# check if user supplied invalid parameters
invalid_params <- !(user_params %in% p_params)
if (any(invalid_params)) {
stop(
"Grading error: the supplied parameters ",
paste0("'", user_params[invalid_params], "'", collapse = ", "), " are invalid."
)
}
# check both the user parameters contained in plot's geom and stat parameters
identical(params, all_params[user_params])
}
#' Which stat is used in the ith layer?
#'
#' \code{ith_stat} returns the type of stat used by the ith layer.
#'
#' @param p A ggplot object
#' @param i A numerical index that corresponds to the first layer of a plot (1),
#' the second layer (2), and so on.
#'
#' @return A character string that corresponds to the suffix of a ggplot2
#' \code{stat_} function, e.g. \code{"qq"}.
#'
#' @family functions for checking stats
#'
#' @export
#'
#' @examples
#' require(ggplot2)
#' p <- ggplot(data = diamonds, aes(sample = price)) +
#' geom_qq()
#' ith_stat(p, i = 1)
ith_stat <- function(p, i) {
stop_if_not_ggplot(p)
stat <- class(p$layers[[i]]$stat)[1]
gsub("stat", "", tolower(stat))
}
#' Is the ith stat what it should be?
#'
#' \code{ith_stat_is} checks whether the ith layer uses the prescribed type of stat
#'
#' @param p A ggplot object
#' @param stat A character string that corresponds to
#' the suffix of a ggplot2 \code{stat_} function, e.g. \code{"identity"}.
#' @param i A numerical index that corresponds to the first layer of a plot (1),
#' the second layer (2), and so on. \code{ith_stat_is} will check the
#' stat used by the ith layer.
#'
#' @return \code{TRUE} or \code{FALSE}
#'
#' @family functions for checking stats
#'
#' @export
#'
#' @examples
#' require(ggplot2)
#' p <- ggplot(data = diamonds, aes(sample = price)) +
#' geom_qq()
#' ith_stat_is(p, i = 1, "qq")
ith_stat_is <- function(p, stat, i = 1) {
stop_if_not_ggplot(p)
stat_i <- ith_stat(p, i)
stat_i == stat
}