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
|
filter_args <- function(x) {
all_names <- names(x)
all_names <- setdiff(all_names, c("self", "data", "scales", "coordinates", "..."))
x[all_names]
}
find_partial_match_pairs <- function(args) {
if (length(args) < 2) {
return(NULL)
}
combinations <- combn(args, 2L)
contains <- startsWith(combinations[1, ], combinations[2, ]) |
startsWith(combinations[2, ], combinations[1, ])
if (!any(contains)) {
return(NULL)
}
problem <- combinations[, contains, drop = FALSE]
paste0("`", problem[1, ], "` with `", problem[2, ], "`")
}
test_that("geom_xxx and GeomXxx$draw arg defaults match", {
ggplot2_ns <- asNamespace("ggplot2")
objs <- ls(ggplot2_ns)
geom_fun_names <- objs[grepl("^(geom|annotation)_", objs)]
# These aren't actually geoms, or need special parameters and can't be tested this way.
geom_fun_names <- setdiff(
geom_fun_names,
c("geom_map", "geom_sf", "geom_smooth", "geom_column", "geom_area",
"geom_density", "annotation_custom", "annotation_map", "annotation_raster",
"annotation_id", "geom_errorbarh")
)
# For each geom_xxx function and the corresponding GeomXxx$draw and
# GeomXxx$draw_groups functions, make sure that if they have same args, that
# the args have the same default values.
lapply(geom_fun_names, function(geom_fun_name) {
geom_fun <- ggplot2_ns[[geom_fun_name]]
geom <- geom_fun()$geom
if (!is_geom(geom)) # for geoms that return more than one thing
return()
fun_args <- formals(geom_fun)
draw_args <- c(
ggproto_formals(geom$draw_layer),
ggproto_formals(geom$draw_group)
)
draw_args <- filter_args(draw_args)
common_names <- intersect(names(fun_args), names(draw_args))
expect_identical(fun_args[common_names], draw_args[common_names],
info = paste0("Mismatch between arg defaults for ", geom_fun_name,
" and ", class(geom_fun()$geom)[1], "'s $draw and/or $draw_group functions.")
)
})
})
test_that("stat_xxx and StatXxx$compute_panel arg defaults match", {
ggplot2_ns <- asNamespace("ggplot2")
objs <- ls(ggplot2_ns)
stat_fun_names <- objs[grepl("^stat_", objs)]
# These aren't actually stats, or need special parameters and can't be tested this way.
stat_fun_names <- setdiff(
stat_fun_names,
c("stat_function", "stat_sf")
)
# Remove deprecated stats
stat_fun_names <- setdiff(stat_fun_names, c("stat_spoke", "stat_summary2d"))
# For each stat_xxx function and the corresponding StatXxx$compute_panel and
# StatXxx$compute_group functions, make sure that if they have same args, that
# the args have the same default values.
lapply(stat_fun_names, function(stat_fun_name) {
stat_fun <- ggplot2_ns[[stat_fun_name]]
calculate <- stat_fun()$stat$compute_panel
calculate_groups <- stat_fun()$stat$compute_group
fun_args <- formals(stat_fun)
calc_args <- c(ggproto_formals(calculate), ggproto_formals(calculate_groups))
calc_args <- filter_args(calc_args)
common_names <- intersect(names(fun_args), names(calc_args))
expect_identical(fun_args[common_names], calc_args[common_names],
info = paste0("Mismatch between arg defaults for ", stat_fun_name,
" and ", class(stat_fun()$stat)[1], "'s $compute_panel and/or $compute_group functions.")
)
})
})
# If the following tests fail, you may have introduced a potential partial match
# in argument names. The code should be double checked that is doesn't
# accidentally use `list$arg` when `list$arg_name` also exists. If that doesn't
# occur, the snapshot can be updated.
test_that("GeomXxx$parameters() does not contain partial matches", {
ggplot2_ns <- asNamespace("ggplot2")
objs <- ls(ggplot2_ns)
geom_class_names <- grep("^Geom", objs, value = TRUE)
geom_class_names <- setdiff(geom_class_names, c("Geom"))
problems <- list()
for (geom_class_name in geom_class_names) {
geom_obj <- ggplot2_ns[[geom_class_name]]
params <- geom_obj$parameters()
issues <- find_partial_match_pairs(params)
if (length(issues) == 0) {
next
}
problems[[geom_class_name]] <- issues
}
problems <- vapply(problems, paste0, character(1), collapse = ", ")
problems <- paste0(format(names(problems)), ": ", problems)
expect_snapshot(problems)
})
test_that("StatXxx$parameters() does not contain partial matches", {
ggplot2_ns <- asNamespace("ggplot2")
objs <- ls(ggplot2_ns)
stat_class_names <- grep("^Stat", objs, value = TRUE)
stat_class_names <- setdiff(stat_class_names, c("Stat"))
problems <- list()
for (stat_class_name in stat_class_names) {
stat_obj <- ggplot2_ns[[stat_class_name]]
params <- stat_obj$parameters()
issues <- find_partial_match_pairs(params)
if (length(issues) == 0) {
next
}
problems[[stat_class_name]] <- issues
}
problems <- vapply(problems, paste0, character(1), collapse = ", ")
problems <- paste0(format(names(problems)), ": ", problems)
expect_snapshot(problems)
})
|
