/
geom.R
executable file
·151 lines (128 loc) · 4.83 KB
/
geom.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
# Helper methods for creating geoms
#
# Author: mjskay
###############################################################################
# from ggstance:::ggname
ggname = function(prefix, grob) {
grob$name = grobName(grob, prefix)
grob
}
# default computed aesthetics ---------------------------------------------
# add default computed aesthetics to a layer --- useful for creating default aesthetics
# that are computed from the input data rather than default non-data-mapped aesthetics
#' @importFrom rlang get_expr as_quosure
add_default_computed_aesthetics = function(l, default_mapping) {
ggproto(NULL, l,
setup_layer = function(self, data, plot) {
data = ggproto_parent(l, self)$setup_layer(data, plot)
for (aesthetic in names(default_mapping)) {
# we don't use exact matching here because if someone is using ggnewscale
# then aesthetic "x" will be replaced with "x_new" and we don't want to
# re-create the default "x" aesthetic mapping in that case.
default_aes_mapping = get_expr(default_mapping[[aesthetic]])
vars_in_mapping = all_names(default_aes_mapping)
if (
# only add the aesthetic if it isn't already set and if the variables it uses
# are in the provided data and none of them are NA
is.null(self$computed_mapping[[aesthetic, exact = FALSE]]) &&
(!isTRUE(self$inherit.aes) || is.null(plot$computed_mapping[[aesthetic, exact = FALSE]])) &&
all(vars_in_mapping %in% names(data)) &&
!anyNA(data[, vars_in_mapping])
) {
# We reconstruct the quosure here instead of using default_mapping[[aesthetic]]
# as a hack because for some reason when this is run inside {covr} it
# gets mangled. So we need to recreate it from the underlying expression
# and the environment (which in this case should be the package
# environment, which is the same as environment(add_default_computed_aesthetics))
self$computed_mapping[[aesthetic]] = as_quosure(
default_aes_mapping,
env = environment(add_default_computed_aesthetics)
)
}
}
data
}
)
}
# orientation detection ---------------------------------------------------
# detects the orientation of the geometry
#' @importFrom ggplot2 has_flipped_aes
get_flipped_aes = function(data, params, ..., secondary_is_dist = NA, main_is_orthogonal = NA) {
params$orientation =
if (params$orientation %in% c("horizontal", "y")) "y"
else if (params$orientation %in% c("vertical", "x")) "x"
else if (is.na(params$orientation)) NA
else stop0("Unknown orientation: ", deparse0(params$orientation))
# checks based on xdist or ydist
if (is.na(params$orientation) && !is.na(secondary_is_dist)) {
if (!is.null(data$xdist)) {
return(secondary_is_dist)
} else if (!is.null(data$ydist)) {
return(!secondary_is_dist)
} else if (!is.null(data$dist)) {
# when dist is provided, we can't determine orientation at this point but
# main_is_orthogonal must be determined by secondary_is_dist
main_is_orthogonal = !secondary_is_dist
}
}
has_flipped_aes(data, params, ..., main_is_orthogonal = main_is_orthogonal)
}
# detects the orientation of the geometry
get_orientation = function(flipped_aes) {
if (flipped_aes) "y"
else "x"
}
# defines "orientation" variables in the environment of the calling
# function (for convenience): these are variables (typically aesthetics)
# that differ depending on whether the geom's orientation is horizontal
# or vertical. They are named assuming a horizontal orientation.
globalVariables(c(
"width.", "height",
"y", "ymin", "ymax", "yend", "y.range",
"x", "xmin", "xmax", "xend", "x.range"
))
define_orientation_variables = function(orientation) {
f = parent.frame()
if (orientation == "horizontal" || orientation == "y") {
f$height = "height"
f$width. = "width"
f$y = "y"
f$ymin = "ymin"
f$ymax = "ymax"
f$yend = "yend"
f$y.range = "y.range"
f$ydist = "ydist"
f$x = "x"
f$xmin = "xmin"
f$xmax = "xmax"
f$xend = "xend"
f$x.range = "x.range"
f$xdist = "xdist"
} else if (orientation == "vertical" || orientation == "x") {
f$height = "width"
f$width. = "height"
f$y = "x"
f$ymin = "xmin"
f$ymax = "xmax"
f$yend = "xend"
f$y.range = "x.range"
f$ydist = "xdist"
f$x = "y"
f$xmin = "ymin"
f$xmax = "ymax"
f$xend = "yend"
f$x.range = "y.range"
f$xdist = "ydist"
} else {
stop0("Unknown orientation: ", deparse0(orientation))
}
}
# ggproto -----------------------------------------------------------------
#' Base ggproto classes for ggdist
#'
#' @seealso [ggproto]
#' @keywords internal
#' @name ggdist-ggproto
NULL
# from ggplot2:::ggproto_formals
ggproto_formals = function(x) formals(environment(x)$f)