Skip to content

Commit 91302e0

Browse files
teunbrandteunbrand
committed
convert theme elements to S7 classes
1 parent d54e464 commit 91302e0

File tree

4 files changed

+142
-112
lines changed

4 files changed

+142
-112
lines changed

‎NAMESPACE

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -106,7 +106,6 @@ S3method(predictdf,default)
106106
S3method(predictdf,glm)
107107
S3method(predictdf,locfit)
108108
S3method(predictdf,loess)
109-
S3method(print,element)
110109
S3method(print,ggplot)
111110
S3method(print,ggplot2_bins)
112111
S3method(print,ggproto)
@@ -344,6 +343,7 @@ export(draw_key_vline)
344343
export(draw_key_vpath)
345344
export(dup_axis)
346345
export(el_def)
346+
export(element)
347347
export(element_blank)
348348
export(element_geom)
349349
export(element_grob)

‎R/theme-elements.R

Lines changed: 136 additions & 109 deletions
Original file line numberDiff line numberDiff line change
@@ -81,55 +81,63 @@ NULL
8181

8282
#' @export
8383
#' @rdname element
84-
element_blank <- function() {
85-
structure(
86-
list(),
87-
class = c("element_blank", "element")
88-
)
89-
}
84+
element <- S7::new_class("element", abstract = TRUE)
9085

9186
#' @export
9287
#' @rdname element
93-
element_rect <- function(fill = NULL, colour = NULL, linewidth = NULL,
94-
linetype = NULL, color = NULL, inherit.blank = FALSE, size = deprecated()) {
88+
element_blank <- S7::new_class("element_blank", parent = element)
9589

96-
if (lifecycle::is_present(size)) {
97-
deprecate_soft0("3.4.0", "element_rect(size)", "element_rect(linewidth)")
98-
linewidth <- size
99-
}
90+
#' @include properties.R
10091

101-
if (!is.null(color)) colour <- color
102-
structure(
103-
list(fill = fill, colour = colour, linewidth = linewidth, linetype = linetype,
104-
inherit.blank = inherit.blank),
105-
class = c("element_rect", "element")
106-
)
107-
}
92+
#' @export
93+
#' @rdname element
94+
element_rect <- S7::new_class(
95+
"element_rect", parent = element,
96+
properties = element_props[c("fill", "colour", "linewidth", "linetype", "inherit.blank")],
97+
constructor = function(fill = NULL, colour = NULL, linewidth = NULL,
98+
linetype = NULL, color = NULL, inherit.blank = FALSE,
99+
size = deprecated()){
100+
if (lifecycle::is_present(size)) {
101+
deprecate_soft0("3.4.0", "element_rect(size)", "element_rect(linewidth)")
102+
linewidth <- size
103+
}
104+
S7::new_object(
105+
S7::S7_object(),
106+
fill = fill, colour = color %||% colour,
107+
linewidth = linewidth, linetype = linetype,
108+
inherit.blank = inherit.blank
109+
)
110+
}
111+
)
108112

109113
#' @export
110114
#' @rdname element
111115
#' @param lineend Line end Line end style (round, butt, square)
112116
#' @param arrow Arrow specification, as created by [grid::arrow()]
113-
element_line <- function(colour = NULL, linewidth = NULL, linetype = NULL,
114-
lineend = NULL, color = NULL, arrow = NULL, arrow.fill = NULL,
115-
inherit.blank = FALSE, size = deprecated()) {
116-
117-
if (lifecycle::is_present(size)) {
118-
deprecate_soft0("3.4.0", "element_line(size)", "element_line(linewidth)")
119-
linewidth <- size
117+
element_line <- S7::new_class(
118+
"element_line", parent = element,
119+
properties = element_props[c(
120+
"colour", "linewidth", "linetype", "lineend", "arrow", "arrow.fill",
121+
"inherit.blank"
122+
)],
123+
constructor = function(colour = NULL, linewidth = NULL, linetype = NULL,
124+
lineend = NULL, color = NULL, arrow = NULL,
125+
arrow.fill = NULL, inherit.blank = FALSE, size = deprecated()) {
126+
if (lifecycle::is_present(size)) {
127+
deprecate_soft0("3.4.0", "element_line(size)", "element_line(linewidth)")
128+
linewidth <- size
129+
}
130+
colour <- color %||% colour
131+
S7::new_object(
132+
S7::S7_object(),
133+
colour = colour,
134+
linewidth = linewidth, linetype = linetype, lineend = lineend,
135+
arrow = arrow %||% FALSE,
136+
arrow.fill = arrow.fill %||% colour,
137+
inherit.blank = inherit.blank
138+
)
120139
}
121-
122-
colour <- color %||% colour
123-
arrow.fill <- arrow.fill %||% colour
124-
arrow <- arrow %||% FALSE
125-
126-
structure(
127-
list(colour = colour, linewidth = linewidth, linetype = linetype, lineend = lineend,
128-
arrow = arrow, arrow.fill = arrow.fill, inherit.blank = inherit.blank),
129-
class = c("element_line", "element")
130-
)
131-
}
132-
140+
)
133141

134142
#' @param family Font family
135143
#' @param face Font face ("plain", "italic", "bold", "bold.italic")
@@ -145,93 +153,116 @@ element_line <- function(colour = NULL, linewidth = NULL, linetype = NULL,
145153
#' is anchored.
146154
#' @export
147155
#' @rdname element
148-
element_text <- function(family = NULL, face = NULL, colour = NULL,
149-
size = NULL, hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL,
150-
color = NULL, margin = NULL, debug = NULL, inherit.blank = FALSE) {
151-
152-
if (!is.null(color)) colour <- color
153-
154-
n <- max(
155-
length(family), length(face), length(colour), length(size),
156-
length(hjust), length(vjust), length(angle), length(lineheight)
157-
)
158-
if (n > 1) {
159-
cli::cli_warn(c(
160-
"Vectorized input to {.fn element_text} is not officially supported.",
161-
"i" = "Results may be unexpected or may change in future versions of ggplot2."
162-
))
163-
}
164-
165-
166-
structure(
167-
list(family = family, face = face, colour = colour, size = size,
156+
element_text <- S7::new_class(
157+
"element_text", parent = element,
158+
properties = element_props[c(
159+
"family", "face", "colour", "size", "hjust", "vjust", "angle", "lineheight",
160+
"margin", "debug", "inherit.blank"
161+
)],
162+
constructor = function(family = NULL, face = NULL, colour = NULL,
163+
size = NULL, hjust = NULL, vjust = NULL, angle = NULL,
164+
lineheight = NULL, color = NULL, margin = NULL,
165+
debug = NULL, inherit.blank = FALSE) {
166+
n <- max(
167+
length(family), length(face), length(colour), length(size),
168+
length(hjust), length(vjust), length(angle), length(lineheight)
169+
)
170+
if (n > 1) {
171+
cli::cli_warn(c(
172+
"Vectorized input to {.fn element_text} is not officially supported.",
173+
"i" = "Results may be unexpected or may change in future versions of ggplot2."
174+
))
175+
}
176+
177+
colour <- color %||% colour
178+
S7::new_object(
179+
S7::S7_object(),
180+
family = family, face = face, colour = colour, size = size,
168181
hjust = hjust, vjust = vjust, angle = angle, lineheight = lineheight,
169-
margin = margin, debug = debug, inherit.blank = inherit.blank),
170-
class = c("element_text", "element")
171-
)
172-
}
182+
margin = margin, debug = debug, inherit.blank = inherit.blank
183+
)
184+
}
185+
)
173186

174187
#' @export
175188
#' @rdname element
176-
element_polygon <- function(fill = NULL, colour = NULL, linewidth = NULL,
177-
linetype = NULL, color = NULL,
178-
inherit.blank = FALSE) {
179-
structure(
180-
list(
189+
element_polygon <- S7::new_class(
190+
"element_polygon", parent = element,
191+
properties = element_props[c(
192+
"fill", "colour", "linewidth", "linetype", "inherit.blank"
193+
)],
194+
constructor = function(fill = NULL, colour = NULL, linewidth = NULL,
195+
linetype = NULL, color = NULL, inherit.blank = FALSE) {
196+
colour <- color %||% colour
197+
S7::new_object(
198+
S7::S7_object(),
181199
fill = fill, colour = color %||% colour, linewidth = linewidth,
182200
linetype = linetype, inherit.blank = inherit.blank
183-
),
184-
class = c("element_polygon", "element")
185-
)
186-
}
201+
)
202+
}
203+
)
187204

188205
#' @export
189206
#' @rdname element
190-
element_point <- function(colour = NULL, shape = NULL, size = NULL, fill = NULL,
191-
stroke = NULL, color = NULL, inherit.blank = FALSE) {
192-
structure(
193-
list(
207+
element_point <- S7::new_class(
208+
"element_point", parent = element,
209+
properties = rename(
210+
element_props[c(
211+
"colour", "shape", "size", "fill", "linewidth", "inherit.blank"
212+
)],
213+
c("linewidth" = "stroke")
214+
),
215+
constructor = function(colour = NULL, shape = NULL, size = NULL, fill = NULL,
216+
stroke = NULL, color = NULL, inherit.blank = FALSE) {
217+
S7::new_object(
218+
S7::S7_object(),
194219
colour = color %||% colour, fill = fill, shape = shape, size = size,
195220
stroke = stroke, inherit.blank = inherit.blank
196-
),
197-
class = c("element_point", "element")
198-
)
199-
}
221+
)
222+
}
223+
)
200224

201225
#' @param ink Foreground colour.
202226
#' @param paper Background colour.
203227
#' @param accent Accent colour.
204228
#' @export
205229
#' @rdname element
206-
element_geom <- function(
207-
# colours
208-
ink = NULL, paper = NULL, accent = NULL,
209-
# linewidth
210-
linewidth = NULL, borderwidth = NULL,
211-
# linetype
212-
linetype = NULL, bordertype = NULL,
213-
# text
214-
family = NULL, fontsize = NULL,
215-
# points
216-
pointsize = NULL, pointshape = NULL) {
217-
218-
if (!is.null(fontsize)) {
219-
fontsize <- fontsize / .pt
220-
}
221-
222-
structure(
223-
list(
224-
ink = ink,
225-
paper = paper,
226-
accent = accent,
230+
element_geom <- S7::new_class(
231+
"element_geom", parent = element,
232+
properties = list(
233+
ink = element_props$colour,
234+
paper = element_props$colour,
235+
accent = element_props$colour,
236+
linewidth = element_props$linewidth,
237+
borderwidth = element_props$linewidth,
238+
linetype = element_props$linetype,
239+
bordertype = element_props$linetype,
240+
family = element_props$family,
241+
fontsize = element_props$size,
242+
pointsize = element_props$size,
243+
pointshape = element_props$shape
244+
),
245+
constructor = function(
246+
ink = NULL, paper = NULL, accent = NULL,
247+
linewidth = NULL, borderwidth = NULL,
248+
linetype = NULL, bordertype = NULL,
249+
family = NULL, fontsize = NULL,
250+
pointsize = NULL, pointshape = NULL) {
251+
252+
if (!is.null(fontsize)) {
253+
fontsize <- fontsize / .pt
254+
}
255+
256+
S7::new_object(
257+
S7::S7_object(),
258+
ink = ink, paper = paper, accent = accent,
227259
linewidth = linewidth, borderwidth = borderwidth,
228260
linetype = linetype, bordertype = bordertype,
229261
family = family, fontsize = fontsize,
230262
pointsize = pointsize, pointshape = pointshape
231-
),
232-
class = c("element_geom", "element")
233-
)
234-
}
263+
)
264+
}
265+
)
235266

236267
.default_geom_element <- element_geom(
237268
ink = "black", paper = "white", accent = "#3366FF",
@@ -243,11 +274,7 @@ element_geom <- function(
243274

244275
#' @export
245276
#' @rdname is_tests
246-
is.theme_element <- function(x) inherits(x, "element")
247-
248-
#' @export
249-
print.element <- function(x, ...) utils::str(x)
250-
277+
is.theme_element <- function(x) S7::S7_inherits(x, element)
251278

252279
#' @param x A single number specifying size relative to parent element.
253280
#' @rdname element

‎R/theme.R

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -543,8 +543,8 @@ theme <- function(...,
543543
# If complete theme set all non-blank elements to inherit from blanks
544544
if (complete) {
545545
elements <- lapply(elements, function(el) {
546-
if (is.theme_element(el) && !inherits(el, "element_blank")) {
547-
el$inherit.blank <- TRUE
546+
if (is.theme_element(el) && S7::prop_exists(el, "inherit.blank")) {
547+
S7::prop(el, "inherit.blank") <- TRUE
548548
}
549549
el
550550
})

‎man/element.Rd

Lines changed: 3 additions & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)