Skip to content

Commit 10eba36

Browse files
yutannihilationyutannihilation
authored
Support guide_axis() on CoordTrans (#3972)
1 parent c8f01c0 commit 10eba36

File tree

6 files changed

+207
-88
lines changed

6 files changed

+207
-88
lines changed

‎NEWS.md‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
11
# ggplot2 (development version)
22

3+
* Improve the support for `guide_axis()` on `coord_trans()` (@yutannihilation, #3959)
4+
35
* `geom_density()` and `stat_density()` now support `bounds` argument
46
to estimate density with boundary correction (@echasnovski, #4013).
57

‎R/coord-.r‎

Lines changed: 76 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -59,7 +59,33 @@ Coord <- ggproto("Coord",
5959

6060
aspect = function(ranges) NULL,
6161

62-
labels = function(labels, panel_params) labels,
62+
labels = function(self, labels, panel_params) {
63+
# If panel params contains guides information, use it.
64+
# Otherwise use the labels as is, for backward-compatibility
65+
if (is.null(panel_params$guide)) {
66+
return(labels)
67+
}
68+
69+
positions_x <- c("top", "bottom")
70+
positions_y <- c("left", "right")
71+
72+
list(
73+
x = lapply(c(1, 2), function(i) {
74+
panel_guide_label(
75+
panel_params$guides,
76+
position = positions_x[[i]],
77+
default_label = labels$x[[i]]
78+
)
79+
}),
80+
y = lapply(c(1, 2), function(i) {
81+
panel_guide_label(
82+
panel_params$guides,
83+
position = positions_y[[i]],
84+
default_label = labels$y[[i]]
85+
)
86+
})
87+
)
88+
},
6389

6490
render_fg = function(panel_params, theme) element_render(theme, "panel.border"),
6591

@@ -92,10 +118,59 @@ Coord <- ggproto("Coord",
92118
},
93119

94120
setup_panel_guides = function(self, panel_params, guides, params = list()) {
121+
aesthetics <- c("x", "y", "x.sec", "y.sec")
122+
names(aesthetics) <- aesthetics
123+
124+
# If the panel_params doesn't contain the scale, do not use a guide for that aesthetic
125+
idx <- vapply(aesthetics, function(aesthetic) {
126+
scale <- panel_params[[aesthetic]]
127+
!is.null(scale) && inherits(scale, "ViewScale")
128+
}, logical(1L))
129+
aesthetics <- aesthetics[idx]
130+
131+
# resolve the specified guide from the scale and/or guides
132+
guides <- lapply(aesthetics, function(aesthetic) {
133+
resolve_guide(
134+
aesthetic,
135+
panel_params[[aesthetic]],
136+
guides,
137+
default = guide_axis(),
138+
null = guide_none()
139+
)
140+
})
141+
142+
# resolve the guide definition as a "guide" S3
143+
guides <- lapply(guides, validate_guide)
144+
145+
# if there is a "position" specification in the scale, pass this on to the guide
146+
# ideally, this should be specified in the guide
147+
guides <- lapply(aesthetics, function(aesthetic) {
148+
guide <- guides[[aesthetic]]
149+
scale <- panel_params[[aesthetic]]
150+
# position could be NULL here for an empty scale
151+
guide$position <- guide$position %|W|% scale$position
152+
guide
153+
})
154+
155+
panel_params$guides <- guides
95156
panel_params
96157
},
97158

98159
train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) {
160+
aesthetics <- c("x", "y", "x.sec", "y.sec")
161+
names(aesthetics) <- aesthetics
162+
# If the panel_params doesn't contain the scale, there's no guide for the aesthetic
163+
aesthetics <- intersect(aesthetics, names(panel_params$guides))
164+
165+
panel_params$guides <- lapply(aesthetics, function(aesthetic) {
166+
axis <- substr(aesthetic, 1, 1)
167+
guide <- panel_params$guides[[aesthetic]]
168+
guide <- guide_train(guide, panel_params[[aesthetic]])
169+
guide <- guide_transform(guide, self, panel_params)
170+
guide <- guide_geom(guide, layers, default_mapping)
171+
guide
172+
})
173+
99174
panel_params
100175
},
101176

‎R/coord-cartesian-.r‎

Lines changed: 1 addition & 71 deletions
Original file line numberDiff line numberDiff line change
@@ -103,75 +103,6 @@ CoordCartesian <- ggproto("CoordCartesian", Coord,
103103
)
104104
},
105105

106-
setup_panel_guides = function(self, panel_params, guides, params = list()) {
107-
aesthetics <- c("x", "y", "x.sec", "y.sec")
108-
names(aesthetics) <- aesthetics
109-
110-
# resolve the specified guide from the scale and/or guides
111-
guides <- lapply(aesthetics, function(aesthetic) {
112-
resolve_guide(
113-
aesthetic,
114-
panel_params[[aesthetic]],
115-
guides,
116-
default = guide_axis(),
117-
null = guide_none()
118-
)
119-
})
120-
121-
# resolve the guide definition as a "guide" S3
122-
guides <- lapply(guides, validate_guide)
123-
124-
# if there is an "position" specification in the scale, pass this on to the guide
125-
# ideally, this should be specified in the guide
126-
guides <- lapply(aesthetics, function(aesthetic) {
127-
guide <- guides[[aesthetic]]
128-
scale <- panel_params[[aesthetic]]
129-
# position could be NULL here for an empty scale
130-
guide$position <- guide$position %|W|% scale$position
131-
guide
132-
})
133-
134-
panel_params$guides <- guides
135-
panel_params
136-
},
137-
138-
train_panel_guides = function(self, panel_params, layers, default_mapping, params = list()) {
139-
aesthetics <- c("x", "y", "x.sec", "y.sec")
140-
names(aesthetics) <- aesthetics
141-
142-
panel_params$guides <- lapply(aesthetics, function(aesthetic) {
143-
axis <- substr(aesthetic, 1, 1)
144-
guide <- panel_params$guides[[aesthetic]]
145-
guide <- guide_train(guide, panel_params[[aesthetic]])
146-
guide <- guide_transform(guide, self, panel_params)
147-
guide <- guide_geom(guide, layers, default_mapping)
148-
guide
149-
})
150-
151-
panel_params
152-
},
153-
154-
labels = function(self, labels, panel_params) {
155-
positions_x <- c("top", "bottom")
156-
positions_y <- c("left", "right")
157-
158-
list(
159-
x = lapply(c(1, 2), function(i) {
160-
panel_guide_label(
161-
panel_params$guides,
162-
position = positions_x[[i]],
163-
default_label = labels$x[[i]]
164-
)
165-
}),
166-
y = lapply(c(1, 2), function(i) {
167-
panel_guide_label(
168-
panel_params$guides,
169-
position = positions_y[[i]],
170-
default_label = labels$y[[i]])
171-
})
172-
)
173-
},
174-
175106
render_bg = function(panel_params, theme) {
176107
guide_grid(
177108
theme,
@@ -206,7 +137,6 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) {
206137
view_scales <- list(
207138
view_scale_primary(scale, limits, continuous_range),
208139
sec = view_scale_secondary(scale, limits, continuous_range),
209-
arrange = scale$axis_order(),
210140
range = continuous_range
211141
)
212142
names(view_scales) <- c(aesthetic, paste0(aesthetic, ".", names(view_scales)[-1]))
@@ -215,7 +145,7 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) {
215145
}
216146

217147
panel_guide_label <- function(guides, position, default_label) {
218-
guide <- guide_for_position(guides, position) %||% guide_none(title = NULL)
148+
guide <- guide_for_position(guides, position) %||% guide_none(title = waiver())
219149
guide$title %|W|% default_label
220150
}
221151

‎R/coord-transform.r‎

Lines changed: 30 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -125,8 +125,18 @@ CoordTrans <- ggproto("CoordTrans", Coord,
125125
},
126126

127127
transform = function(self, data, panel_params) {
128-
trans_x <- function(data) transform_value(self$trans$x, data, panel_params$x.range)
129-
trans_y <- function(data) transform_value(self$trans$y, data, panel_params$y.range)
128+
# trans_x() and trans_y() needs to keep Inf values because this can be called
129+
# in guide_transform.axis()
130+
trans_x <- function(data) {
131+
idx <- !is.infinite(data)
132+
data[idx] <- transform_value(self$trans$x, data[idx], panel_params$x.range)
133+
data
134+
}
135+
trans_y <- function(data) {
136+
idx <- !is.infinite(data)
137+
data[idx] <- transform_value(self$trans$y, data[idx], panel_params$y.range)
138+
data
139+
}
130140

131141
new_data <- transform_position(data, trans_x, trans_y)
132142

@@ -138,8 +148,8 @@ CoordTrans <- ggproto("CoordTrans", Coord,
138148

139149
setup_panel_params = function(self, scale_x, scale_y, params = list()) {
140150
c(
141-
train_trans(scale_x, self$limits$x, self$trans$x, "x", self$expand),
142-
train_trans(scale_y, self$limits$y, self$trans$y, "y", self$expand)
151+
view_scales_from_scale_with_coord_trans(scale_x, self$limits$x, self$trans$x, self$expand),
152+
view_scales_from_scale_with_coord_trans(scale_y, self$limits$y, self$trans$y, self$expand)
143153
)
144154
},
145155

@@ -154,20 +164,16 @@ CoordTrans <- ggproto("CoordTrans", Coord,
154164
},
155165

156166
render_axis_h = function(panel_params, theme) {
157-
arrange <- panel_params$x.arrange %||% c("secondary", "primary")
158-
159167
list(
160-
top = render_axis(panel_params, arrange[1], "x", "top", theme),
161-
bottom = render_axis(panel_params, arrange[2], "x", "bottom", theme)
168+
top = panel_guides_grob(panel_params$guides, position = "top", theme = theme),
169+
bottom = panel_guides_grob(panel_params$guides, position = "bottom", theme = theme)
162170
)
163171
},
164172

165173
render_axis_v = function(panel_params, theme) {
166-
arrange <- panel_params$y.arrange %||% c("primary", "secondary")
167-
168174
list(
169-
left = render_axis(panel_params, arrange[1], "y", "left", theme),
170-
right = render_axis(panel_params, arrange[2], "y", "right", theme)
175+
left = panel_guides_grob(panel_params$guides, position = "left", theme = theme),
176+
right = panel_guides_grob(panel_params$guides, position = "right", theme = theme)
171177
)
172178
}
173179
)
@@ -178,14 +184,16 @@ transform_value <- function(trans, value, range) {
178184
rescale(trans$transform(value), 0:1, range)
179185
}
180186

181-
train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) {
187+
# TODO: can we merge this with view_scales_from_scale()?
188+
view_scales_from_scale_with_coord_trans <- function(scale, coord_limits, trans, expand = TRUE) {
182189
expansion <- default_expansion(scale, expand = expand)
183190
scale_trans <- scale$trans %||% identity_trans()
184191
coord_limits <- coord_limits %||% scale_trans$inverse(c(NA, NA))
192+
scale_limits <- scale$get_limits()
185193

186194
if (scale$is_discrete()) {
187195
continuous_ranges <- expand_limits_discrete_trans(
188-
scale$get_limits(),
196+
scale_limits,
189197
expansion,
190198
coord_limits,
191199
trans,
@@ -195,7 +203,7 @@ train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) {
195203
# transform user-specified limits to scale transformed space
196204
coord_limits <- scale$trans$transform(coord_limits)
197205
continuous_ranges <- expand_limits_continuous_trans(
198-
scale$get_limits(),
206+
scale_limits,
199207
expansion,
200208
coord_limits,
201209
trans
@@ -216,6 +224,10 @@ train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) {
216224
out$sec.minor_source <- transform_value(trans, out$sec.minor_source, out$range)
217225

218226
out <- list(
227+
# Note that a ViewScale requires a limit and a range that are before the
228+
# Coord's transformation, so we pass `continuous_range`, not `continuous_range_coord`.
229+
view_scale_primary(scale, scale_limits, continuous_ranges$continuous_range),
230+
sec = view_scale_secondary(scale, scale_limits, continuous_ranges$continuous_range),
219231
range = out$range,
220232
labels = out$labels,
221233
major = out$major_source,
@@ -224,7 +236,9 @@ train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) {
224236
sec.major = out$sec.major_source,
225237
sec.minor = out$sec.minor_source
226238
)
227-
names(out) <- paste(name, names(out), sep = ".")
239+
240+
aesthetic <- scale$aesthetics[1]
241+
names(out) <- c(aesthetic, paste(aesthetic, names(out)[-1], sep = "."))
228242
out
229243
}
230244

‎tests/testthat/_snaps/guides/guide-titles-with-coord-trans.svg‎

Lines changed: 80 additions & 0 deletions
Loading

0 commit comments

Comments
 (0)