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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
#' @section Coordinate systems:
#'
#' All `coord_*()` functions (like `coord_trans()`) return a `Coord*`
#' object (like `CoordTrans`).
#'
#' Each of the `Coord*` objects is a [ggproto()] object,
#' descended from the top-level `Coord`. To create a new type of Coord
#' object, you typically will want to implement one or more of the following:
#'
#' - `aspect`: Returns the desired aspect ratio for the plot.
#' - `labels`: Returns a list containing labels for x and y.
#' - `render_fg`: Renders foreground elements.
#' - `render_bg`: Renders background elements.
#' - `render_axis_h`: Renders the horizontal axes.
#' - `render_axis_v`: Renders the vertical axes.
#' - `backtransform_range(panel_params)`: Extracts the panel range provided
#' in `panel_params` (created by `setup_panel_params()`, see below) and
#' back-transforms to data coordinates. This back-transformation can be needed
#' for coords such as `coord_trans()` where the range in the transformed
#' coordinates differs from the range in the untransformed coordinates. Returns
#' a list of two ranges, `x` and `y`, and these correspond to the variables
#' mapped to the `x` and `y` aesthetics, even for coords such as `coord_flip()`
#' where the `x` aesthetic is shown along the y direction and vice versa.
#' - `range(panel_params)`: Extracts the panel range provided
#' in `panel_params` (created by `setup_panel_params()`, see below) and
#' returns it. Unlike `backtransform_range()`, this function does not perform
#' any back-transformation and instead returns final transformed coordinates. Returns
#' a list of two ranges, `x` and `y`, and these correspond to the variables
#' mapped to the `x` and `y` aesthetics, even for coords such as `coord_flip()`
#' where the `x` aesthetic is shown along the y direction and vice versa.
#' - `transform`: Transforms x and y coordinates.
#' - `distance`: Calculates distance.
#' - `is_linear`: Returns `TRUE` if the coordinate system is
#' linear; `FALSE` otherwise.
#' - `is_free`: Returns `TRUE` if the coordinate system supports free
#' positional scales; `FALSE` otherwise.
#' - `setup_panel_params(scale_x, scale_y, params)`: Determines the appropriate
#' x and y ranges for each panel, and also calculates anything else needed to
#' render the panel and axes, such as tick positions and labels for major
#' and minor ticks. Returns all this information in a named list.
#' - `setup_data(data, params)`: Allows the coordinate system to
#' manipulate the plot data. Should return list of data frames.
#' - `setup_layout(layout, params)`: Allows the coordinate
#' system to manipulate the `layout` data frame which assigns
#' data to panels and scales.
#'
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
Coord <- ggproto("Coord",
# Is this the default coordinate system?
default = FALSE,
# should drawing be clipped to the extent of the plot panel?
# "on" = yes, "off" = no
clip = "on",
aspect = function(ranges) NULL,
labels = function(self, labels, panel_params) {
# If panel params contains guides information, use it.
# Otherwise use the labels as is, for backward-compatibility
if (is.null(panel_params$guides)) {
return(labels)
}
positions_x <- c("top", "bottom")
positions_y <- c("left", "right")
list(
x = lapply(c(1, 2), function(i) {
panel_guide_label(
panel_params$guides,
position = positions_x[[i]],
default_label = labels$x[[i]]
)
}),
y = lapply(c(1, 2), function(i) {
panel_guide_label(
panel_params$guides,
position = positions_y[[i]],
default_label = labels$y[[i]]
)
})
)
},
render_fg = function(panel_params, theme) element_render(theme, "panel.border"),
render_bg = function(self, panel_params, theme) {
cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn render_bg} method")
},
render_axis_h = function(self, panel_params, theme) {
cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn render_axis_h} method")
},
render_axis_v = function(self, panel_params, theme) {
cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn render_axis_v} method")
},
# transform range given in transformed coordinates
# back into range in given in (possibly scale-transformed)
# data coordinates
backtransform_range = function(self, panel_params) {
cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn backtransform_range} method")
},
# return range stored in panel_params
range = function(self, panel_params) {
cli::cli_abort("{.fn {snake_class(self)}} has not implemented a {.fn range} method")
},
setup_panel_params = function(scale_x, scale_y, params = list()) {
list()
},
setup_panel_guides = function(self, panel_params, guides, params = list()) {
aesthetics <- c("x", "y", "x.sec", "y.sec")
names(aesthetics) <- aesthetics
# If the panel_params doesn't contain the scale, do not use a guide for that aesthetic
idx <- vapply(aesthetics, function(aesthetic) {
scale <- panel_params[[aesthetic]]
!is.null(scale) && inherits(scale, "ViewScale")
}, logical(1L))
aesthetics <- aesthetics[idx]
# resolve the specified guide from the scale and/or guides
guides <- lapply(aesthetics, function(aesthetic) {
resolve_guide(
aesthetic,
panel_params[[aesthetic]],
guides,
default = guide_axis(),
null = guide_none()
)
})
# resolve the guide definition as a "guide" S3
guides <- lapply(guides, validate_guide)
# if there is a "position" specification in the scale, pass this on to the guide
# ideally, this should be specified in the guide
guides <- lapply(aesthetics, function(aesthetic) {
guide <- guides[[aesthetic]]
scale <- panel_params[[aesthetic]]
# position could be NULL here for an empty scale
guide$position <- guide$position %|W|% scale$position
guide
})
panel_params$guides <- guides
panel_params
},
train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) {
aesthetics <- c("x", "y", "x.sec", "y.sec")
# If the panel_params doesn't contain the scale, there's no guide for the aesthetic
aesthetics <- intersect(aesthetics, names(panel_params$guides))
names(aesthetics) <- aesthetics
panel_params$guides <- lapply(aesthetics, function(aesthetic) {
axis <- substr(aesthetic, 1, 1)
guide <- panel_params$guides[[aesthetic]]
guide <- guide_train(guide, panel_params[[aesthetic]])
guide <- guide_transform(guide, self, panel_params)
guide <- guide_geom(guide, layers, default_mapping)
guide
})
panel_params
},
transform = function(data, range) NULL,
distance = function(x, y, panel_params) NULL,
is_linear = function() FALSE,
# Does the coordinate system support free scaling of axes in a faceted plot?
# Will generally have to return FALSE for coordinate systems that enforce a fixed aspect ratio.
is_free = function() FALSE,
setup_params = function(data) {
list()
},
setup_data = function(data, params = list()) {
data
},
setup_layout = function(layout, params) {
layout
},
# Optionally, modify list of x and y scales in place. Currently
# used as a fudge for CoordFlip and CoordPolar
modify_scales = function(scales_x, scales_y) {
invisible()
}
)
#' Is this object a coordinate system?
#'
#' @export is.Coord
#' @keywords internal
is.Coord <- function(x) inherits(x, "Coord")
# Renders an axis with the correct orientation or zeroGrob if no axis should be
# generated
render_axis <- function(panel_params, axis, scale, position, theme) {
if (axis == "primary") {
draw_axis(panel_params[[paste0(scale, ".major")]], panel_params[[paste0(scale, ".labels")]], position, theme)
} else if (axis == "secondary" && !is.null(panel_params[[paste0(scale, ".sec.major")]])) {
draw_axis(panel_params[[paste0(scale, ".sec.major")]], panel_params[[paste0(scale, ".sec.labels")]], position, theme)
} else {
zeroGrob()
}
}
|
